relational-query 0.9.5.1 → 0.10.0.0

raw patch · 105 files changed

+6427/−6327 lines, 105 filesdep +product-isomorphicdep ~persistable-recordPVP ok

version bump matches the API change (PVP)

Dependencies added: product-isomorphic

Dependency ranges changed: persistable-record

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−2
• relational-query.cabal +59/−49
• src/Database/Relational.hs +95/−0
• src/Database/Relational/Arrow.hs +447/−0
• src/Database/Relational/BaseTH.hs +76/−0
• src/Database/Relational/Compat.hs +121/−0
• src/Database/Relational/Config.hs +19/−0
• src/Database/Relational/Constraint.hs +113/−0
• src/Database/Relational/Context.hs +15/−0
• src/Database/Relational/Derives.hs +114/−0
• src/Database/Relational/Effect.hs +185/−0
• src/Database/Relational/Internal/Config.hs +74/−0
• src/Database/Relational/Internal/ContextType.hs +39/−0
• src/Database/Relational/Internal/String.hs +62/−0
• src/Database/Relational/Internal/UntypedTable.hs +44/−0
• src/Database/Relational/Monad/Aggregate.hs +103/−0
• src/Database/Relational/Monad/Assign.hs +48/−0
• src/Database/Relational/Monad/BaseType.hs +95/−0
• src/Database/Relational/Monad/Class.hs +94/−0
• src/Database/Relational/Monad/Register.hs +31/−0
• src/Database/Relational/Monad/Restrict.hs +46/−0
• src/Database/Relational/Monad/Simple.hs +67/−0
• src/Database/Relational/Monad/Trans/Aggregating.hs +170/−0
• src/Database/Relational/Monad/Trans/Assigning.hs +84/−0
• src/Database/Relational/Monad/Trans/Config.hs +41/−0
• src/Database/Relational/Monad/Trans/Join.hs +106/−0
• src/Database/Relational/Monad/Trans/JoinState.hs +45/−0
• src/Database/Relational/Monad/Trans/Ordering.hs +113/−0
• src/Database/Relational/Monad/Trans/Qualify.hs +54/−0
• src/Database/Relational/Monad/Trans/Restricting.hs +72/−0
• src/Database/Relational/Monad/Type.hs +37/−0
• src/Database/Relational/Monad/Unique.hs +59/−0
• src/Database/Relational/Pi.hs +42/−0
• src/Database/Relational/Pi/Unsafe.hs +182/−0
• src/Database/Relational/Projectable.hs +539/−0
• src/Database/Relational/ProjectableClass.hs +73/−0
• src/Database/Relational/ProjectableExtended.hs +168/−0
• src/Database/Relational/Pure.hs +160/−0
• src/Database/Relational/Query.hs +10/−85
• src/Database/Relational/Query/Arrow.hs +10/−439
• src/Database/Relational/Query/BaseTH.hs +0/−85
• src/Database/Relational/Query/Component.hs +0/−27
• src/Database/Relational/Query/Constraint.hs +0/−113
• src/Database/Relational/Query/Context.hs +0/−15
• src/Database/Relational/Query/Derives.hs +0/−113
• src/Database/Relational/Query/Effect.hs +0/−190
• src/Database/Relational/Query/Internal/BaseSQL.hs +0/−96
• src/Database/Relational/Query/Internal/Config.hs +0/−74
• src/Database/Relational/Query/Internal/ContextType.hs +0/−39
• src/Database/Relational/Query/Internal/GroupingSQL.hs +0/−119
• src/Database/Relational/Query/Internal/Product.hs +0/−53
• src/Database/Relational/Query/Internal/SQL.hs +0/−52
• src/Database/Relational/Query/Internal/Sub.hs +0/−204
• src/Database/Relational/Query/Internal/UntypedTable.hs +0/−44
• src/Database/Relational/Query/Monad/Aggregate.hs +0/−103
• src/Database/Relational/Query/Monad/Assign.hs +0/−49
• src/Database/Relational/Query/Monad/BaseType.hs +0/−95
• src/Database/Relational/Query/Monad/Class.hs +0/−95
• src/Database/Relational/Query/Monad/Register.hs +0/−31
• src/Database/Relational/Query/Monad/Restrict.hs +0/−47
• src/Database/Relational/Query/Monad/Simple.hs +0/−69
• src/Database/Relational/Query/Monad/Trans/Aggregating.hs +0/−169
• src/Database/Relational/Query/Monad/Trans/Assigning.hs +0/−85
• src/Database/Relational/Query/Monad/Trans/Config.hs +0/−41
• src/Database/Relational/Query/Monad/Trans/Join.hs +0/−106
• src/Database/Relational/Query/Monad/Trans/JoinState.hs +0/−42
• src/Database/Relational/Query/Monad/Trans/Ordering.hs +0/−122
• src/Database/Relational/Query/Monad/Trans/Qualify.hs +0/−54
• src/Database/Relational/Query/Monad/Trans/Restricting.hs +0/−71
• src/Database/Relational/Query/Monad/Type.hs +0/−38
• src/Database/Relational/Query/Monad/Unique.hs +0/−59
• src/Database/Relational/Query/Pi.hs +0/−42
• src/Database/Relational/Query/Pi/Unsafe.hs +0/−188
• src/Database/Relational/Query/Projectable.hs +0/−551
• src/Database/Relational/Query/ProjectableClass.hs +0/−102
• src/Database/Relational/Query/ProjectableExtended.hs +0/−201
• src/Database/Relational/Query/Projection.hs +0/−208
• src/Database/Relational/Query/Pure.hs +0/−162
• src/Database/Relational/Query/Relation.hs +0/−387
• src/Database/Relational/Query/SQL.hs +0/−118
• src/Database/Relational/Query/Scalar.hs +0/−32
• src/Database/Relational/Query/Sub.hs +0/−329
• src/Database/Relational/Query/TH.hs +0/−464
• src/Database/Relational/Query/Table.hs +0/−72
• src/Database/Relational/Query/TupleInstances.hs +0/−28
• src/Database/Relational/Query/Type.hs +0/−353
• src/Database/Relational/Record.hs +203/−0
• src/Database/Relational/Relation.hs +192/−0
• src/Database/Relational/Scalar.hs +32/−0
• src/Database/Relational/Set.hs +213/−0
• src/Database/Relational/SimpleSql.hs +106/−0
• src/Database/Relational/SqlSyntax.hs +25/−0
• src/Database/Relational/SqlSyntax/Aggregate.hs +94/−0
• src/Database/Relational/SqlSyntax/Fold.hs +270/−0
• src/Database/Relational/SqlSyntax/Join.hs +54/−0
• src/Database/Relational/SqlSyntax/Query.hs +114/−0
• src/Database/Relational/SqlSyntax/Types.hs +210/−0
• src/Database/Relational/SqlSyntax/Updates.hs +63/−0
• src/Database/Relational/TH.hs +475/−0
• src/Database/Relational/Table.hs +81/−0
• src/Database/Relational/TupleInstances.hs +27/−0
• src/Database/Relational/Type.hs +334/−0
• test/Model.hs +2/−2
• test/sqlsEq.hs +8/−7
• test/sqlsEqArrow.hs +8/−6

@@ -1,8 +1,10 @@ <!-- -*- Markdown -*- --> -## 0.9.5.1+## 0.10.0.0 -- add an upper bound of version constraint.+- switch namespace to Database.Relational+- update interfaces about projection types.+- divide and apply product-isomorphic interfaces.  ## 0.9.5.0 

@@ -1,5 +1,5 @@ name:                relational-query-version:             0.9.5.1+version:             0.10.0.0 synopsis:            Typeful, Modular, Relational, algebraic query engine description:         This package contiains typeful relation structure and                      relational-algebraic query building DSL which can@@ -28,57 +28,64 @@  library   exposed-modules:-                       Database.Relational.Query.Arrow+                       Database.Relational.Arrow +                       Database.Relational+                       Database.Relational.Table+                       Database.Relational.SimpleSql+                       Database.Relational.Pure+                       Database.Relational.Pi+                       Database.Relational.Pi.Unsafe+                       Database.Relational.Constraint+                       Database.Relational.Context+                       Database.Relational.Config+                       Database.Relational.SqlSyntax+                       Database.Relational.Record+                       Database.Relational.ProjectableClass+                       Database.Relational.Projectable+                       Database.Relational.ProjectableExtended+                       Database.Relational.TupleInstances+                       Database.Relational.Monad.BaseType+                       Database.Relational.Monad.Class+                       Database.Relational.Monad.Trans.Ordering+                       Database.Relational.Monad.Trans.Aggregating+                       Database.Relational.Monad.Trans.Restricting+                       Database.Relational.Monad.Trans.Join+                       Database.Relational.Monad.Trans.Config+                       Database.Relational.Monad.Trans.Assigning+                       Database.Relational.Monad.Type+                       Database.Relational.Monad.Simple+                       Database.Relational.Monad.Aggregate+                       Database.Relational.Monad.Unique+                       Database.Relational.Monad.Restrict+                       Database.Relational.Monad.Assign+                       Database.Relational.Monad.Register+                       Database.Relational.Relation+                       Database.Relational.Set+                       Database.Relational.Effect+                       Database.Relational.Scalar+                       Database.Relational.Type+                       Database.Relational.Derives+                       Database.Relational.BaseTH+                       Database.Relational.TH++                       Database.Relational.Compat                        Database.Relational.Query-                       Database.Relational.Query.Table-                       Database.Relational.Query.SQL-                       Database.Relational.Query.Pure-                       Database.Relational.Query.Pi-                       Database.Relational.Query.Pi.Unsafe-                       Database.Relational.Query.Constraint-                       Database.Relational.Query.Context-                       Database.Relational.Query.Component-                       Database.Relational.Query.Sub-                       Database.Relational.Query.Projection-                       Database.Relational.Query.ProjectableClass-                       Database.Relational.Query.Projectable-                       Database.Relational.Query.ProjectableExtended-                       Database.Relational.Query.TupleInstances-                       Database.Relational.Query.Monad.BaseType-                       Database.Relational.Query.Monad.Class-                       Database.Relational.Query.Monad.Trans.Ordering-                       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.Unique-                       Database.Relational.Query.Monad.Restrict-                       Database.Relational.Query.Monad.Assign-                       Database.Relational.Query.Monad.Register-                       Database.Relational.Query.Relation-                       Database.Relational.Query.Effect-                       Database.Relational.Query.Scalar-                       Database.Relational.Query.Type-                       Database.Relational.Query.Derives-                       Database.Relational.Query.BaseTH-                       Database.Relational.Query.TH+                       Database.Relational.Query.Arrow    other-modules:-                       Database.Relational.Query.Internal.Config-                       Database.Relational.Query.Internal.ContextType-                       Database.Relational.Query.Internal.SQL-                       Database.Relational.Query.Internal.BaseSQL-                       Database.Relational.Query.Internal.GroupingSQL-                       Database.Relational.Query.Internal.UntypedTable-                       Database.Relational.Query.Internal.Product-                       Database.Relational.Query.Internal.Sub-                       Database.Relational.Query.Monad.Trans.JoinState-                       Database.Relational.Query.Monad.Trans.Qualify+                       Database.Relational.Internal.ContextType+                       Database.Relational.Internal.Config+                       Database.Relational.Internal.String+                       Database.Relational.Internal.UntypedTable+                       Database.Relational.SqlSyntax.Types+                       Database.Relational.SqlSyntax.Join+                       Database.Relational.SqlSyntax.Aggregate+                       Database.Relational.SqlSyntax.Query+                       Database.Relational.SqlSyntax.Fold+                       Database.Relational.SqlSyntax.Updates+                       Database.Relational.Monad.Trans.JoinState+                       Database.Relational.Monad.Trans.Qualify    build-depends:         base <5                        , array@@ -91,9 +98,10 @@                        , dlist                        , template-haskell                        , th-reify-compat+                       , product-isomorphic >= 0.0.3                        , sql-words >=0.1.5                        , names-th-                       , persistable-record >= 0.5.1 && < 0.6+                       , persistable-record >= 0.6   if impl(ghc == 7.4.*)     build-depends:        ghc-prim == 0.2.* @@ -105,6 +113,7 @@ test-suite sqls   build-depends:         base <5                        , quickcheck-simple+                       , product-isomorphic                        , relational-query                        , containers                        , transformers@@ -125,6 +134,7 @@ test-suite sqlsArrow   build-depends:         base <5                        , quickcheck-simple+                       , product-isomorphic                        , relational-query                        , containers                        , transformers

@@ -0,0 +1,95 @@+-- |+-- Module      : Database.Relational+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module is integrated module of Query.+module Database.Relational (+  module Database.Relational.Table,+  module Database.Relational.SimpleSql,+  module Database.Relational.Pi,+  module Database.Relational.Constraint,+  module Database.Relational.Context,+  module Database.Relational.Config,+  module Database.Relational.SqlSyntax,+  module Database.Relational.Record,+  module Database.Relational.ProjectableClass,+  module Database.Relational.Projectable,+  module Database.Relational.ProjectableExtended,+  module Database.Relational.TupleInstances,+  module Database.Relational.Monad.BaseType,+  module Database.Relational.Monad.Class,+  module Database.Relational.Monad.Trans.Ordering,+  module Database.Relational.Monad.Trans.Aggregating,+  module Database.Relational.Monad.Trans.Assigning,+  module Database.Relational.Monad.Type,+  module Database.Relational.Monad.Simple,+  module Database.Relational.Monad.Aggregate,+  module Database.Relational.Monad.Restrict,+  module Database.Relational.Monad.Unique,+  module Database.Relational.Monad.Assign,+  module Database.Relational.Monad.Register,+  module Database.Relational.Relation,+  module Database.Relational.Set,+  module Database.Relational.Scalar,+  module Database.Relational.Type,+  module Database.Relational.Effect,+  module Database.Relational.Derives+  ) where++import Database.Relational.Table (Table, TableDerivable (..))+import Database.Relational.SimpleSql (QuerySuffix, updateOtherThanKeySQL)+import Database.Relational.Pure ()+import Database.Relational.Pi+import Database.Relational.Constraint+  (Key, tableConstraint, projectionKey,+   uniqueKey, -- notNullKey,+   HasConstraintKey(constraintKey),+   derivedUniqueKey, -- derivedNotNullKey,+   Primary, Unique, NotNull)+import Database.Relational.Context+import Database.Relational.Config+import Database.Relational.SqlSyntax+  (Order (..), Nulls (..), AggregateKey, Record, Predicate, PI,+   SubQuery, unitSQL, queryWidth, )+import Database.Relational.Record (RecordList, list)+import Database.Relational.ProjectableClass+import Database.Relational.Projectable+import Database.Relational.ProjectableExtended+import Database.Relational.TupleInstances+import Database.Relational.Monad.BaseType+import Database.Relational.Monad.Class+  (MonadQualify,+   MonadRestrict, wheres, having, restrict,+   MonadAggregate, groupBy, groupBy',+   MonadQuery, query', queryMaybe',+   MonadPartition, partitionBy,+   distinct, all', on)+import Database.Relational.Monad.Trans.Ordering (orderBy', orderBy, asc, desc)+import Database.Relational.Monad.Trans.Aggregating+  (key, key', set, bkey, rollup, cube, groupingSets)+import Database.Relational.Monad.Trans.Assigning (assignTo, (<-#))+import Database.Relational.Monad.Type+import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery)+import Database.Relational.Monad.Aggregate+  (QueryAggregate, AggregatedQuery, Window, over)+import Database.Relational.Monad.Restrict (Restrict)+import Database.Relational.Monad.Unique (QueryUnique)+import Database.Relational.Monad.Assign (Assign)+import Database.Relational.Monad.Register (Register)+import Database.Relational.Relation+import Database.Relational.Set+import Database.Relational.Scalar (ScalarDegree)+import Database.Relational.Type hiding+  (unsafeTypedKeyUpdate, unsafeTypedDelete,+   unsafeTypedInsert, unsafeTypedInsertQuery, )+import Database.Relational.Effect+import Database.Relational.Derives++import Database.Record.Instances ()++{-# ANN module "HLint: ignore Use import/export shortcut" #-}

@@ -0,0 +1,447 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module      : Database.Relational.Arrow+-- Copyright   : 2015-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines arrow version combinators which+-- improves type-safty on building queries.+-- Referencing the local projected records may cause to break+-- the result query.+-- It is possible to controls injection of previous local projected records+-- by restricting domain type of arrow. This idea is imported from Opaleye:+--+--   * <https://github.com/tomjaguarpaw/haskell-opaleye>+--   * <https://github.com/khibino/haskell-relational-record/issues/19>+--+-- Importing this module instead of "Database.Relational.Query" enables+-- to build query using arrow combinators.+module Database.Relational.Arrow (+  module Database.Relational,++  all', distinct,++  query, queryMaybe, query', queryMaybe',+  queryList, queryList', queryExists, queryExists', queryListU, queryListU',+  queryScalar, queryScalar', queryScalarU, queryScalarU',++  uniqueQuery', uniqueQueryMaybe',++  on, wheres, having, groupBy, placeholder,++  relation, relation', aggregateRelation, aggregateRelation',++  uniqueRelation',++  groupBy', key, key', set, bkey, rollup, cube, groupingSets,++  orderBy', orderBy, asc, desc,++  partitionBy, over,++  assign,++  derivedUpdate', derivedUpdate,+  derivedInsertValue', derivedInsertValue,+  derivedDelete', derivedDelete,++  QueryA,++  QuerySimple, QueryAggregate, QueryUnique,++  AggregatingSet, AggregatingSetList, AggregatingPowerSet,++  Orderings, Window, Assignings,++  AssignStatement, Register, RestrictedStatement,+  ) where++import Control.Category (Category)+import Control.Arrow (Arrow, Kleisli (..))++import Database.Record++import Database.Relational hiding+  (all', distinct,+   query, queryMaybe, query', queryMaybe',+   queryList, queryList', queryScalar, queryScalar',+   uniqueQuery', uniqueQueryMaybe',+   on, wheres, having, groupBy, placeholder,+   relation, relation', aggregateRelation, aggregateRelation', uniqueRelation',+   groupBy', key, key', set, bkey, rollup, cube, groupingSets,+   orderBy', orderBy, asc, desc, partitionBy, over,+   derivedUpdate', derivedUpdate,+   derivedInsertValue', derivedInsertValue,+   derivedDelete', derivedDelete,+   QuerySimple, QueryAggregate, QueryUnique, Window, Register)+import qualified Database.Relational as Monadic+import qualified Database.Relational.Monad.Trans.Aggregating as Monadic+import qualified Database.Relational.Monad.Trans.Ordering as Monadic+import qualified Database.Relational.Monad.Trans.Assigning as Monadic+++-- | Arrow to build queries.+newtype QueryA m a b = QueryA (Kleisli m a b) deriving (Category, Arrow)++queryA :: (a -> m b) -> QueryA m a b+queryA = QueryA . Kleisli++runQueryA :: QueryA m a b -> a -> m b+runQueryA (QueryA k) = runKleisli k++runAofM :: (m b -> c) -> QueryA m () b -> c+runAofM = (. (`runQueryA` ()))++-- | Arrow type corresponding to 'Monadic.QuerySimple'+type QuerySimple    = QueryA Monadic.QuerySimple++-- | Arrow type corresponding to 'Monadic.QueryAggregate'+type QueryAggregate = QueryA Monadic.QueryAggregate++-- | Arrow type corresponding to 'Monadic.QueryUnique'+type QueryUnique = QueryA Monadic.QueryUnique++-- | Arrow type corresponding to 'Monadic.AggregatingSet'+type AggregatingSet = QueryA Monadic.AggregatingSet++-- | Arrow type corresponding to 'Monadic.AggregatingSetList'+type AggregatingSetList = QueryA Monadic.AggregatingSetList++-- | Arrow type corresponding to 'Monadic.AggregatingPowerSet'+type AggregatingPowerSet = QueryA Monadic.AggregatingPowerSet++-- | Arrow type corresponding to 'Monadic.Orderings'+type Orderings c m = QueryA (Monadic.Orderings c m)++-- | Arrow type corresponding to 'Monadic.Window'+type Window c = QueryA (Monadic.Window c)++-- | Arrow type corresponding to 'Monadic.Assignings'+type Assignings r m = QueryA (Monadic.Assignings r m)++-- | Arrow type corresponding to 'Monadic.AssignStatement'+type AssignStatement r a = Assignings r Restrict (Record Flat r) a++-- | Arrow type corresponding to 'Monadic.Register'+type Register r a = QueryA (Monadic.Register r) () a++-- | Arrow type corresponding to 'Monadic.RestrictedStatement'+type RestrictedStatement r a = QueryA Monadic.Restrict (Record Flat r) a+++-- | Same as 'Monadic.all''. Arrow version.+all' :: MonadQuery m => QueryA m () ()+all' = queryA $ \() -> Monadic.all'++-- | Same as 'Monadic.distinct'. Arrow version.+distinct :: MonadQuery m => QueryA m () ()+distinct = queryA $ \() -> Monadic.distinct++-- | Same as 'Monadic.query'. Arrow version.+--   The result arrow is not injected by local projected records.+query :: (MonadQualify ConfigureQuery m, MonadQuery m)+      => Relation () r -> QueryA m () (Record Flat r)+query r = queryA $ \() -> Monadic.query r++-- | Same as 'Monadic.queryMaybe'. Arrow version.+--   The result arrow is not injected by any local projected records.+queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m)+           => Relation () r -> QueryA m () (Record Flat (Maybe r))+queryMaybe r = queryA $ \() -> Monadic.queryMaybe r++-- | Same as 'Monadic.query''. Arrow version.+--   The result arrow is not injected by any local projected records.+query' :: (MonadQualify ConfigureQuery m, MonadQuery m)+       => Relation p r -> QueryA m () (PlaceHolders p, Record Flat r)+query' r = queryA $ \() -> Monadic.query' r++-- | Same as 'Monadic.queryMaybe''. Arrow version.+--   The result arrow is not injected by any local projected records.+queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m)+            => Relation p r -> QueryA m () (PlaceHolders p, Record Flat (Maybe r))+queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r++unsafeQueryList :: MonadQualify ConfigureQuery m+            => (a -> Relation () r)+            -> QueryA m a (RecordList (Record c) r)+unsafeQueryList rf = queryA $ Monadic.queryList . rf++unsafeQueryList' :: MonadQualify ConfigureQuery m+             => (a -> Relation p r)+             -> QueryA m a (PlaceHolders p, RecordList (Record c) r)+unsafeQueryList' rf = queryA $ Monadic.queryList' . rf++-- | Same as 'Monadic.queryList'. Arrow version.+--   The result arrow is designed to be injected by local projected records.+queryList :: MonadQualify ConfigureQuery m+          => (Record c a -> Relation () r)+          -> QueryA m (Record c a) (RecordList (Record c) r)+queryList = unsafeQueryList++-- | Same as 'Monadic.queryList''. Arrow version.+--   The result arrow is designed to be injected by local projected records.+queryList' :: MonadQualify ConfigureQuery m+           => (Record c a -> Relation p r)+           -> QueryA m (Record c a) (PlaceHolders p, RecordList (Record c) r)+queryList' = unsafeQueryList'++-- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version.+--   The result arrow is designed to be injected by local projected records.+queryExists :: MonadQualify ConfigureQuery m+          => (Record c a -> Relation () r)+          -> QueryA m (Record c a) (RecordList (Record Exists) r)+queryExists = unsafeQueryList++-- | Same as 'Monadic.queryList'' to pass this result to 'exists' operator. Arrow version.+--   The result arrow is designed to be injected by local projected records.+queryExists' :: MonadQualify ConfigureQuery m+           => (Record c a -> Relation p r)+           -> QueryA m (Record c a) (PlaceHolders p, RecordList (Record Exists) r)+queryExists' = unsafeQueryList'++-- | Same as 'Monadic.queryList'. Arrow version.+--   Useful for no reference cases to local projected records.+queryListU :: MonadQualify ConfigureQuery m+           => Relation () r+           -> QueryA m () (RecordList (Record c) r)+queryListU r = unsafeQueryList $ \() -> r++-- | Same as 'Monadic.queryList''. Arrow version.+--   Useful for no reference cases to local projected records.+queryListU' :: MonadQualify ConfigureQuery m+           => Relation p r+           -> QueryA m () (PlaceHolders p, RecordList (Record c) r)+queryListU' r = unsafeQueryList' $ \() -> r++unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)+                  => (a -> UniqueRelation () c r)+                  -> QueryA m a (Record c (Maybe r))+unsafeQueryScalar rf = queryA $ Monadic.queryScalar . rf++unsafeQueryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)+                   => (a -> UniqueRelation p c r)+                   -> QueryA m a (PlaceHolders p, Record c (Maybe r))+unsafeQueryScalar' rf = queryA $ Monadic.queryScalar' . rf++-- | Same as 'Monadic.queryScalar'. Arrow version.+--   The result arrow is designed to be injected by any local projected record.+queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)+            => (Record c a -> UniqueRelation () c r)+            -> QueryA m (Record c a) (Record c (Maybe r))+queryScalar = unsafeQueryScalar++-- | Same as 'Monadic.queryScalar''. Arrow version.+--   The result arrow is designed to be injected by any local projected record.+queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)+             => (Record c a -> UniqueRelation p c r)+             -> QueryA m (Record c a) (PlaceHolders p, Record c (Maybe r))+queryScalar' = unsafeQueryScalar'++-- | Same as 'Monadic.queryScalar'. Arrow version.+--   Useful for no reference cases to local projected records.+queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r)+            => UniqueRelation () c r+            -> QueryA m () (Record c (Maybe r))+queryScalarU r = unsafeQueryScalar $ \() -> r++-- | Same as 'Monadic.queryScalar''. Arrow version.+--   Useful for no reference cases to local projected records.+queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r)+             => UniqueRelation p c r+             -> QueryA m () (PlaceHolders p, Record c (Maybe r))+queryScalarU' r = unsafeQueryScalar' $ \() -> r++-- | Same as 'Monadic.uniqueQuery''. Arrow version.+--   The result arrow is not injected by local projected records.+uniqueQuery' :: UniqueRelation p c r+             -> QueryA Monadic.QueryUnique () (PlaceHolders p, Record c r)+uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r++-- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version.+--   The result arrow is not injected by local projected records.+uniqueQueryMaybe' :: UniqueRelation p c r+                  -> QueryA Monadic.QueryUnique () (PlaceHolders p, Record c (Maybe r))+uniqueQueryMaybe' r = queryA $ \() -> Monadic.uniqueQueryMaybe' r++-- | Same as 'Monadic.on'. Arrow version.+--   The result arrow is designed to be injected by local conditional flat-records.+on :: MonadQuery m+   => QueryA m (Predicate Flat) ()+on = queryA Monadic.on++-- | Same as 'Monadic.wheres'. Arrow version.+--   The result arrow is designed to be injected by local conditional flat-records.+wheres :: MonadRestrict Flat m+       => QueryA m (Predicate Flat) ()+wheres = queryA Monadic.wheres++-- | Same as 'Monadic.having'. Arrow version.+--   The result arrow is designed to be injected by local conditional aggregated-records.+having :: MonadRestrict Aggregated m+       => QueryA m (Predicate Aggregated) ()+having = queryA Monadic.having++-- | Same as 'Monadic.groupBy'. Arrow version.+--   The result arrow is designed to be injected by local flat-records.+groupBy :: MonadAggregate m+        => QueryA m (Record Flat r) (Record Aggregated r)+groupBy = queryA Monadic.groupBy++-- | Same as 'Monadic.placeholder'. Arrow version.+--   The result arrow is designed to be injected by locally built arrow using placeholders.+placeholder :: (PersistableWidth t, SqlContext c, Monad m)+            => QueryA m (QueryA m (Record c t) a) (PlaceHolders t, a)+placeholder = queryA $ Monadic.placeholder . runQueryA++-- | Same as 'Monadic.relation'.+--   Finalize query-building arrow instead of query-building monad.+relation :: QuerySimple () (Record Flat r)+         -> Relation () r+relation = runAofM Monadic.relation++-- | Same as 'Monadic.relation''.+--   Finalize query-building arrow instead of query-building monad.+relation' :: QuerySimple () (PlaceHolders p, Record Flat r)+          -> Relation p r+relation' = runAofM Monadic.relation'++-- | Same as 'Monadic.aggregateRelation'.+--   Finalize query-building arrow instead of query-building monad.+aggregateRelation :: QueryAggregate () (Record Aggregated r)+                  -> Relation () r+aggregateRelation = runAofM Monadic.aggregateRelation++-- | Same as 'Monadic.aggregateRelation''.+--   Finalize query-building arrow instead of query-building monad.+aggregateRelation' :: QueryAggregate () (PlaceHolders p, Record Aggregated r)+                   -> Relation p r+aggregateRelation' = runAofM Monadic.aggregateRelation'++-- | Same as 'Monadic.uniqueRelation''.+--   Finalize query-building arrow instead of query-building monad.+uniqueRelation' :: QueryUnique () (PlaceHolders p, Record c r)+                -> UniqueRelation p c r+uniqueRelation' = runAofM Monadic.uniqueRelation'++-- | Same as 'Monadic.groupBy''.+--   This arrow is designed to be injected by local 'AggregateKey'.+groupBy' :: MonadAggregate m => QueryA m (AggregateKey (Record Aggregated r)) (Record Aggregated r)+groupBy' = queryA Monadic.groupBy'++-- | Same as 'Monadic.key'.+--   This arrow is designed to be injected by local flat-records.+key :: AggregatingSet (Record Flat r) (Record Aggregated (Maybe r))+key = queryA Monadic.key++-- | Same as 'Monadic.key''.+--   This arrow is designed to be injected by local 'AggregteKey'.+key' :: AggregatingSet (AggregateKey a) a+key' = queryA Monadic.key'++-- | Same as 'Monadic.set'.+--   This arrow is designed to be injected by locally built 'AggregtingSet' arrow.+set :: AggregatingSetList (AggregatingSet () a) a+set = queryA $ runAofM Monadic.set++-- | Same as 'Monadic.bkey'.+--   This arrow is designed to be injected by local flat-records.+bkey :: AggregatingPowerSet (Record Flat r) (Record Aggregated (Maybe r))+bkey = queryA Monadic.bkey++-- | Same as 'Monadic.rollup'.+--   Finalize locally built 'AggregatingPowerSet'.+rollup :: AggregatingPowerSet () a -> AggregateKey a+rollup = runAofM Monadic.rollup++-- | Same as 'Monadic.cube'.+--   Finalize locally built 'AggregatingPowerSet'.+cube :: AggregatingPowerSet () a -> AggregateKey a+cube = runAofM Monadic.cube++-- | Same as 'Monadic.groupingSets'.+--   Finalize locally built 'AggregatingSetList'.+groupingSets :: AggregatingSetList () a -> AggregateKey a+groupingSets = runAofM Monadic.groupingSets++-- | Same as 'Monadic.orderBy''.+--   The result arrow is designed to be injected by local projected records.+orderBy' :: Monad m+         => Order+         -> Nulls+         -> Orderings c m (Record c t) ()+orderBy' o n = queryA $ \p -> Monadic.orderBy' p o n++-- | Same as 'Monadic.orderBy'.+--   The result arrow is designed to be injected by local projected records.+orderBy :: Monad m+        => Order+        -> Orderings c m (Record c t) ()+orderBy o = queryA (`Monadic.orderBy` o)++-- | Same as 'Monadic.asc'.+--   The result arrow is designed to be injected by local projected records.+asc :: Monad m+    => Orderings c m (Record c t) ()+asc = queryA Monadic.asc++-- | Same as 'Monadic.desc'.+--   The result arrow is designed to be injected by local projected records.+desc :: Monad m+     => Orderings c m (Record c t) ()+desc = queryA Monadic.desc++-- | Same as 'Monadic.partitionBy'.+--   The result arrow is designed to be injected by local projected records.+partitionBy :: Window c (Record c r) ()+partitionBy = queryA Monadic.partitionBy++-- | Same as 'Monadic.over'.+--   Make record of window function result using built 'Window' arrow.+over :: SqlContext c+     => Record OverWindow a -> Window c () () -> Record c a+over po = runAofM $ Monadic.over po++infix 8 `over`++-- | Make 'Monadic.AssignTarget' into arrow which is designed to be+--   injected by assignees of local projected record.+assign :: Monad m+       => Monadic.AssignTarget r v+       -> Assignings r m (Record Flat v) ()+assign t = queryA (`Monadic.assignTo` t)++-- | Same as 'Monadic.derivedUpdate''.+--   Make 'Update' from assigning statement arrow using configuration.+derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p+derivedUpdate' config = Monadic.derivedUpdate' config . runQueryA++-- | Same as 'Monadic.derivedUpdate'.+--   Make 'Update' from assigning statement arrow.+derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p+derivedUpdate = Monadic.derivedUpdate . runQueryA++-- | Same as 'Monadic.derivedInsertValue''.+--   Make 'Insert' from register arrow using configuration.+derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p+derivedInsertValue' config = Monadic.derivedInsertValue' config . ($ ()) . runQueryA++-- | Same as 'Monadic.derivedInsertValue'.+--   Make 'Insert' from register arrow.+derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p+derivedInsertValue = Monadic.derivedInsertValue . ($ ()) . runQueryA++-- | Same as 'Monadic.derivedDelete''.+--   Make 'Update' from restrict statement arrow using configuration.+derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p+derivedDelete' config = Monadic.derivedDelete' config . runQueryA++-- | Same as 'Monadic.derivedDelete'.+--   Make 'Update' from restrict statement arrow.+derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p+derivedDelete = Monadic.derivedDelete . runQueryA

@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}++-- |+-- Module      : Database.Relational.BaseTH+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines templates for internally using.+module Database.Relational.BaseTH (+  defineTupleShowConstantInstance,+  defineTuplePi,++  defineRecordProjections,+  ) where++import Control.Applicative ((<$>))+import Data.List (foldl', inits)+import Language.Haskell.TH+  (Q, Name, mkName, normalB, classP, varP,+   TypeQ, forallT, varT, tupleT, appT,+   Dec, sigD, valD, instanceD,+   TyVarBndr (PlainTV), )+import Database.Record.Persistable+  (PersistableWidth, persistableWidth,+   PersistableRecordWidth, runPersistableRecordWidth)++import Database.Relational.ProjectableClass (ShowConstantTermsSQL (..))+import Database.Relational.Pi.Unsafe (Pi, definePi)+++tupleN :: Int -> (([Name], [TypeQ]), TypeQ)+tupleN n = ((ns, vs), foldl' appT (tupleT n) vs)+  where+    ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]+    vs = map varT ns++-- | Make template of 'ShowConstantTermsSQL' instance of tuple type.+defineTupleShowConstantInstance :: Int -> Q [Dec]+defineTupleShowConstantInstance n = do+  let ((_, vs), tty)  =  tupleN n+  (:[]) <$> instanceD+    -- in template-haskell 2.8 or older, Pred is not Type+    (mapM (classP ''ShowConstantTermsSQL . (:[])) vs)+    [t| ShowConstantTermsSQL $tty |]+    []++-- | Make polymorphic projection templates.+defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec]+defineRecordProjections tyRec avs sels cts =+    fmap concat . sequence $ zipWith3 template cts (inits cts) sels+  where+    template :: TypeQ -> [TypeQ] -> Name -> Q [Dec]+    template ct pcts selN = do+      sig <- sigD selN $+             forallT (map PlainTV avs)+             (mapM (classP ''PersistableWidth . (:[]) . varT) avs)+             [t| Pi $tyRec $ct |]+      let runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]+      val <- valD (varP selN)+             (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] pcts) |]) []+      return [sig, val]++-- | Make templates of projection paths for tuple types.+defineTuplePi :: Int -> Q [Dec]+defineTuplePi n =+  defineRecordProjections tyRec avs sels cts+  where+    ((avs, cts), tyRec) = tupleN n+    sels = [ mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"+           | i <- [ 0 .. n - 1] ]

@@ -0,0 +1,121 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}++-- |+-- Module      : Database.Relational.Compat+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module contains backward compatibility definitions of+-- relational-query <= 0.9.*+module Database.Relational.Compat+  {-# DEPRECATED "backward compatibility definitions relational-query <= 0.9.*" #-} (+  -- * deprecated types+  Projection, ListProjection,++  -- * deprecated classes+  ProductConstructor (..),+  ProjectableFunctor, (|$|), ProjectableApplicative, (|*|),++  ProjectableIdZip, rightId, leftId,++  SqlProjectable (..), unsafeProjectSql,+  ProjectableShowSql (..), unsafeShowSql,++  -- * deprecated defintions about Pi+  pfmap, pap, pzero,+  ) where++import Data.Functor.ProductIsomorphic+  (ProductIsoFunctor, (|$|), ProductIsoApplicative, (|*|),+   ProductIsoEmpty, pureE, peRight, peLeft, )+import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..))++import Database.Relational hiding (unsafeShowSql', unsafeShowSql, unsafeProjectSqlTerms, unsafeProjectSql, )+import Database.Relational.Internal.String (showStringSQL, stringSQL)+import qualified Database.Relational.Record as Record+import qualified Database.Relational.Projectable as Projectable++{-# DEPRECATED Projection "Replaced by Record type" #-}+-- | deprecated 'Projection' type replaced by 'Record' type.+type Projection = Record++{-# DEPRECATED ListProjection "Replaced by RecordList type" #-}+-- | deprecated 'Projection' type replaced by 'Record' type.+type ListProjection = RecordList++{-# DEPRECATED ProjectableFunctor "use ProductIsoFunctor in Data.Functor.ProductIsomorphic instead of this. " #-}+-- | deprecated 'ProjectableFunctor' class replaced by 'ProductIsoFunctor' class.+type ProjectableFunctor = ProductIsoFunctor++{-# DEPRECATED ProjectableApplicative "use ProductIsoApplicative in Data.Functor.ProductIsomorphic instead of this. " #-}+-- | deprecated 'ProjectableApplicative' class replaced by 'ProductIsoApplicative' class.+type ProjectableApplicative = ProductIsoApplicative++{-# DEPRECATED ProjectableIdZip "use ProductIsoEmpty in Data.Functor.ProductIsomorphic instead of this. " #-}+-- | deprecated 'ProjectableIdZip' class replaced by 'ProductIsoEmpty' class.+type ProjectableIdZip p = ProductIsoEmpty p ()++{-# DEPRECATED rightId "use peRight in Data.Functor.ProductIsomorphic instead of this. " #-}+-- | deprecated right-id-law definition replaced by 'peRight'+rightId :: ProjectableIdZip p => p (a, ()) -> p a+rightId = peRight++{-# DEPRECATED leftId "use peLeft in Data.Functor.ProductIsomorphic instead of this. " #-}+-- | deprecated left-id-law definition replaced by 'peLeft'+leftId :: ProjectableIdZip p => p ((), a) -> p a+leftId = peLeft++-- Pi++{-# DEPRECATED pfmap "use (|$|) in Data.Functor.ProductIsomorphic instead of this." #-}+-- | deprecated map definition for Pi type. use ('|$|') instead of this.+pfmap :: ProductConstructor (a -> b) => (a -> b) -> Pi r a -> Pi r b+pfmap = (|$|)++{-# DEPRECATED pap "use (|*|) in Data.Functor.ProductIsomorphic instead of this." #-}+-- | deprecated ap definition for Pi type. use ('|*|') instead of this.+pap :: Pi r (a -> b) -> Pi r a -> Pi r b+pap = (|*|)++{-# DEPRECATED pzero "use pureE in Data.Functor.ProductIsomorphic instead of this." #-}+-- | deprecated empty definition for Pi type. use 'pureE' instead of this.+pzero :: Pi a ()+pzero = pureE++-- type classes++{-# DEPRECATED SqlProjectable "use 'SqlContext c => Record c a' instead of 'SqlProjectable p => p a'." #-}+-- | Interface to project SQL terms unsafely.+class SqlProjectable p where+  -- | Unsafely project from SQL expression terms.+  unsafeProjectSqlTerms :: [StringSQL] -- ^ SQL expression strings+                        -> p t         -- ^ Result record+{-# DEPRECATED unsafeProjectSqlTerms "Use Database.Relational.unsafeProjectSqlTerms instead of this." #-}++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext c => SqlProjectable (Record c) where+  unsafeProjectSqlTerms = Projectable.unsafeProjectSqlTerms++{-# DEPRECATED unsafeProjectSql "Use Database.Relational.unsafeProjectSql instead of this." #-}+unsafeProjectSql :: SqlProjectable p => String -> p a+unsafeProjectSql = unsafeProjectSqlTerms . (:[]) . stringSQL++{-# DEPRECATED ProjectableShowSql "specialized type 'Record c' should be used instead of this constraint." #-}+-- | Interface to get SQL expression from a record.+class ProjectableShowSql p where+  unsafeShowSql' :: p a -> StringSQL+{-# DEPRECATED unsafeShowSql' "Use Database.Relational.unsafeShowSql' instead of this." #-}++instance ProjectableShowSql (Record c) where+  unsafeShowSql' = Record.unsafeStringSql++{-# DEPRECATED unsafeShowSql "Use Database.Relational.unsafeShowSql instead of this." #-}+unsafeShowSql :: ProjectableShowSql p => p a -> String+unsafeShowSql = showStringSQL . unsafeShowSql'

@@ -0,0 +1,19 @@+-- |+-- Module      : Database.Relational.Config+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides untyped components for query.+module Database.Relational.Config+       ( -- * Configuration type for query+         module Database.Relational.Internal.Config,+       ) where++import Database.Relational.Internal.Config+  (NameConfig (..),+   ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..),+   Config (..), defaultConfig,)

@@ -0,0 +1,113 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.Relational.Constraint+-- Copyright   : 2013-2017 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.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.Record (PersistableRecordWidth, PersistableWidth (persistableWidth))+import Database.Record.KeyConstraint+  (KeyConstraint, unsafeSpecifyKeyConstraint,+   Primary, Unique, NotNull)+import qualified Database.Record.KeyConstraint as C++import Database.Relational.Pi (Pi)+import qualified Database.Relational.Pi.Unsafe as UnsafePi+++-- | 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++-- | Inferred '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++-- -- | Inferred '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

@@ -0,0 +1,15 @@+-- |+-- Module      : Database.Relational.Context+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module re-export query context tag types.+module Database.Relational.Context+       ( module Database.Relational.Internal.ContextType+       ) where++import Database.Relational.Internal.ContextType

@@ -0,0 +1,114 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.Relational.Derives+-- Copyright   : 2013-2017 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.Derives (+  -- * Query derivation+  specifiedKey,++  unique,++  primary', primary,++  -- * Update derivation+  updateByConstraintKey,+  primaryUpdate,++  updateValuesWithKey,++  -- * Derived objects from table+  derivedUniqueRelation+  ) where++import Database.Record (PersistableWidth, ToSql)+import Database.Record.ToSql (unsafeUpdateValuesWithIndexes)++import Database.Relational.SqlSyntax (Record)++import Database.Relational.Table (Table, TableDerivable)+import Database.Relational.Pi.Unsafe (Pi, unsafeExpandIndexes)+import qualified Database.Relational.Record as Record+import Database.Relational.Projectable (placeholder, (.=.))+import Database.Relational.ProjectableExtended ((!))+import Database.Relational.Monad.Class (wheres)+import Database.Relational.Monad.BaseType (Relation, relationWidth)+import Database.Relational.Relation+  (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique)+import Database.Relational.Constraint+   (Key, Primary, Unique, projectionKey, uniqueKey,+    HasConstraintKey(constraintKey))+import qualified Database.Relational.Constraint as Constraint+import Database.Relational.Type (KeyUpdate, typedKeyUpdate)+++-- | 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 $ Record.wpi (relationWidth rel) 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 inferred 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 . unsafeExpandIndexes++-- | 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' = typedKeyUpdate table' . Constraint.projectionKey++-- | Typed 'KeyUpdate' using inferred primary key.+primaryUpdate :: (HasConstraintKey Primary r p)+              => Table r       -- ^ 'Table' to update+              -> KeyUpdate p r -- ^ Result typed 'Update'+primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey)++-- | 'UniqueRelation' inferred from table.+derivedUniqueRelation :: TableDerivable r+                      => Key Unique r k        -- ^ Unique key proof object which record type is 'a' and key type is 'p'.+                      -> Record c k            -- ^ Unique key value to specify.+                      -> UniqueRelation () c r -- ^ Result restricted 'Relation'+derivedUniqueRelation uk kp = unsafeUnique . relation $ do+  r <- query derivedRelation+  wheres $ r ! projectionKey uk .=. Record.unsafeChangeContext kp+  return r

@@ -0,0 +1,185 @@+-- |+-- Module      : Database.Relational.Effect+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines effect statements+-- like update and delete.+module Database.Relational.Effect (+  -- * Object to express simple restriction.+  Restriction, restriction, restriction',++  -- * Object to express update target columns and restriction.+  UpdateTarget, updateTarget, updateTarget',+  liftTargetAllColumn, liftTargetAllColumn',+  updateTargetAllColumn, updateTargetAllColumn',++  -- * Object to express insert terget.+  InsertTarget, insertTarget, insertTarget', piRegister,++  -- * Generate SQL from restriction.+  sqlWhereFromRestriction,+  sqlFromUpdateTarget,+  sqlChunkFromInsertTarget,+  sqlFromInsertTarget,+  ) where++import Data.Monoid ((<>))+import Data.Functor.ProductIsomorphic (peRight)++import Language.SQL.Keyword (Keyword(..))+import Database.Record.Persistable (PersistableWidth)++import Database.Relational.Internal.Config (Config (chunksInsertSize), defaultConfig)+import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL)+import Database.Relational.SqlSyntax+  (composeWhere, composeSets, composeChunkValuesWithColumns)++import Database.Relational.Pi (Pi, id')+import qualified Database.Relational.Pi.Unsafe as Pi+import Database.Relational.Table (Table, TableDerivable, derivedTable)+import qualified Database.Relational.Table as Table+import qualified Database.Relational.Record as Record+import Database.Relational.Projectable+  (PlaceHolders, unitPlaceHolder,+   pwPlaceholder, placeholder, (><), )+import Database.Relational.Monad.Trans.Assigning (assignings, (<-#))+import Database.Relational.Monad.Restrict (RestrictedStatement)+import qualified Database.Relational.Monad.Restrict as Restrict+import Database.Relational.Monad.Assign (AssignStatement)+import qualified Database.Relational.Monad.Assign as Assign+import Database.Relational.Monad.Register (Register)+import qualified Database.Relational.Monad.Register as Register+++-- | Restriction type with place-holder parameter 'p' and projected record type 'r'.+newtype Restriction p r = Restriction (RestrictedStatement r (PlaceHolders p))++-- | Finalize 'Restrict' monad and generate 'Restriction'.+restriction :: RestrictedStatement r () -> Restriction () r+restriction = Restriction . ((>> return unitPlaceHolder) .)++-- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p'+restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r+restriction' = Restriction++runRestriction :: Restriction p r+               -> RestrictedStatement r (PlaceHolders p)+runRestriction (Restriction qf) = qf++-- | SQL WHERE clause 'StringSQL' string from 'Restriction'.+sqlWhereFromRestriction :: Config -> Table r -> Restriction p r -> StringSQL+sqlWhereFromRestriction config tbl (Restriction q) = composeWhere rs+  where (_ph, rs) = Restrict.extract (q $ Record.unsafeFromTable tbl) config++-- | Show where clause.+instance TableDerivable r => Show (Restriction p r) where+  show = showStringSQL . sqlWhereFromRestriction defaultConfig derivedTable+++-- | UpdateTarget type with place-holder parameter 'p' and projected record type 'r'.+newtype UpdateTarget p r = UpdateTarget (AssignStatement r (PlaceHolders p))++-- | Finalize 'Target' monad and generate 'UpdateTarget'.+updateTarget :: AssignStatement r ()+             -> UpdateTarget () r+updateTarget =  UpdateTarget . ((>> return unitPlaceHolder) .)++-- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'.+updateTarget' :: AssignStatement r (PlaceHolders p)+              -> UpdateTarget p r+updateTarget' = UpdateTarget++updateAllColumn :: PersistableWidth r+                => Restriction p r+                -> AssignStatement r (PlaceHolders (r, p))+updateAllColumn rs proj = do+  (ph0, ()) <- placeholder (\ph -> 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' $ \proj -> fmap peRight $ updateAllColumn rs 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+                      => RestrictedStatement r ()+                      -> UpdateTarget r r+updateTargetAllColumn = liftTargetAllColumn . restriction++-- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'.+updateTargetAllColumn' :: PersistableWidth r+                       => RestrictedStatement r (PlaceHolders p)+                       -> UpdateTarget (r, p) r+updateTargetAllColumn' = liftTargetAllColumn' . restriction'+++-- | SQL SET clause and WHERE clause 'StringSQL' string from 'UpdateTarget'+sqlFromUpdateTarget :: Config -> Table r -> UpdateTarget p r -> StringSQL+sqlFromUpdateTarget config tbl (UpdateTarget q) = composeSets (asR tbl) <> composeWhere rs+  where ((_ph, asR), rs) = Assign.extract (q (Record.unsafeFromTable tbl)) config++instance TableDerivable r => Show (UpdateTarget p r) where+  show = showStringSQL . sqlFromUpdateTarget defaultConfig derivedTable+++-- | InsertTarget type with place-holder parameter 'p' and projected record type 'r'.+newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p))++-- | Finalize 'Register' monad and generate 'InsertTarget'.+insertTarget :: Register r ()+             -> InsertTarget () r+insertTarget =  InsertTarget . (>> return unitPlaceHolder)++-- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'.+insertTarget' :: Register r (PlaceHolders p)+              -> InsertTarget p r+insertTarget' = InsertTarget++-- | parametalized 'Register' monad from 'Pi'+piRegister :: PersistableWidth r+           => Pi r r'+           -> Register r (PlaceHolders r')+piRegister pi' = do+  let (ph', ma) = pwPlaceholder (Pi.width' pi') (\ph -> pi' <-# ph)+  () <- ma+  return ph'++sqlChunkFromInsertTarget' :: Config+                          -> Int+                          -> Table r+                          -> InsertTarget p r+                          -> StringSQL+sqlChunkFromInsertTarget' config sz tbl (InsertTarget q) =+    INSERT <> INTO <> stringSQL (Table.name tbl) <> composeChunkValuesWithColumns sz (asR tbl)+  where+    (_ph, asR) = Register.extract q config++-- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget'+sqlChunkFromInsertTarget :: Config+                         -> Table r+                         -> InsertTarget p r+                         -> (StringSQL, Int)+sqlChunkFromInsertTarget config tbl it =+    (sqlChunkFromInsertTarget' config n tbl it, n)+  where+    th = chunksInsertSize config+    n  = (th + w - 1) `quot` w+    w  = Table.width tbl++-- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget'+sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL+sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1

@@ -0,0 +1,74 @@+-- |+-- Module      : Database.Relational.Internal.Config+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines configuration datatype used in query products.+module Database.Relational.Internal.Config (+  NameConfig (..),+  ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..),+  Config ( productUnitSupport+         , chunksInsertSize+         , schemaNameMode+         , normalizedTableName+         , verboseAsCompilerWarning+         , identifierQuotation+         , nameConfig),+  defaultConfig,+  ) where++import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName)+import qualified Database.Record.TH as RecordTH+++-- | 'NameConfig' type to customize names of expanded templates.+data NameConfig =+  NameConfig+  { recordConfig       ::  RecordTH.NameConfig+  , relationVarName    ::  String -> String -> VarName+  }++instance Show NameConfig where+  show = const "<NameConfig>"++-- | Unit of product is supported or not.+data ProductUnitSupport = PUSupported | PUNotSupported  deriving Show++-- | Schema name qualify mode in SQL string.+data SchemaNameMode+  = SchemaQualified     -- ^ Schema qualified table name in SQL string+  | SchemaNotQualified  -- ^ Not qualified table name in SQL string+  deriving (Eq, Show)++-- | Configuration for quotation of identifiers of SQL.+data IdentifierQuotation = NoQuotation | Quotation Char deriving Show++-- | Configuration type.+data Config =+  Config+  { productUnitSupport        ::  !ProductUnitSupport+  , chunksInsertSize          ::  !Int+  , schemaNameMode            ::  !SchemaNameMode+  , normalizedTableName       ::  !Bool+  , verboseAsCompilerWarning  ::  !Bool+  , identifierQuotation       ::  !IdentifierQuotation+  , nameConfig                ::  !NameConfig+  } deriving Show++-- | Default configuration.+defaultConfig :: Config+defaultConfig =+  Config { productUnitSupport        =  PUSupported+         , chunksInsertSize          =  256+         , schemaNameMode            =  SchemaQualified+         , normalizedTableName       =  True+         , verboseAsCompilerWarning  =  False+         , identifierQuotation       =  NoQuotation+         , nameConfig                =  NameConfig { recordConfig     =  RecordTH.defaultNameConfig+                                                   , relationVarName  =  const varCamelcaseName+                                                   }+         }

@@ -0,0 +1,39 @@+{-# LANGUAGE EmptyDataDecls #-}++-- |+-- Module      : Database.Relational.Internal.ContextType+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines query context tag types.+module Database.Relational.Internal.ContextType (+  Flat, Aggregated, Exists, OverWindow,++  Set, SetList, Power,+  ) 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 window function building+data OverWindow+++-- | Type tag for normal aggregatings set+data Set++-- | Type tag for aggregatings GROUPING SETS+data SetList++-- | Type tag for aggregatings power set+data Power

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module      : Database.Relational.Internal.String+-- Copyright   : 2014-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides SQL string wrap interfaces.+module Database.Relational.Internal.String (+  StringSQL, stringSQL, showStringSQL,++  rowStringSQL, rowPlaceHolderStringSQL,++  rowConsStringSQL, listStringSQL,++  boolSQL,+  ) where++import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren)+++-- | String wrap type for SQL strings.+type StringSQL = Keyword++-- | 'StringSQL' from 'String'.+stringSQL :: String -> StringSQL+stringSQL =  word++-- | 'StringSQL' to 'String'.+showStringSQL :: StringSQL -> String+showStringSQL =  wordShow++-- | Row String of SQL values.+rowStringSQL :: [StringSQL] -> StringSQL+rowStringSQL =  d  where+  d []  = error "Record: no columns. empty row is not allowed in SQL."+  d [c] = c+  d cs  = paren $ fold (|*|) cs++-- | Place holder row String of SQL.+rowPlaceHolderStringSQL :: Int -> StringSQL+rowPlaceHolderStringSQL =  rowStringSQL . (`replicate` stringSQL "?")++-- | List String of SQL.+rowConsStringSQL :: [StringSQL] -> StringSQL+rowConsStringSQL =  paren . fold (|*|)++-- | List String of SQL.+listStringSQL :: [StringSQL] -> StringSQL+listStringSQL =  paren . fold (|*|)++-- | SQL expressions for Bool type.+boolSQL :: Bool -> StringSQL+boolSQL =+    stringSQL . d+  where+    d True  = "(0=0)"+    d False = "(0=1)"

@@ -0,0 +1,44 @@+-- |+-- Module      : Database.Relational.Internal.UntypedTable+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines no-phantom table type which has table metadatas.+module Database.Relational.Internal.UntypedTable (+  Untyped (Untyped), name', width', columns', (!),+  ) where++import Data.Array (Array, elems)+import qualified Data.Array as Array++import Database.Relational.Internal.String (StringSQL)+++-- | Untyped typed table type+data Untyped = Untyped String Int (Array Int StringSQL)  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 StringSQL+columnArray (Untyped _ _ c) = c++-- | Column name strings in SQL+columns' :: Untyped -> [StringSQL]+columns' =  elems . columnArray++-- | Column name string in SQL specified by index+(!) :: Untyped+    -> Int       -- ^ Column index+    -> StringSQL -- ^ Column name String in SQL+t ! i = columnArray t Array.! i

@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Aggregate+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module contains definitions about aggregated query type.+module Database.Relational.Monad.Aggregate (+  -- * Aggregated Query+  QueryAggregate,+  AggregatedQuery,++  toSQL,++  toSubQuery,++  Window, over+  ) where++import Data.Functor.Identity (Identity (runIdentity))+import Data.Monoid ((<>))++import Language.SQL.Keyword (Keyword(..))+import qualified Language.SQL.Keyword as SQL++import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow)+import Database.Relational.SqlSyntax+  (Duplication, Record, SubQuery, Predicate, JoinProduct,+   OrderingTerm, composeOrderBy, aggregatedSubQuery,+   AggregateColumnRef, AggregateElem, composePartitionBy, )+import qualified Database.Relational.SqlSyntax as Syntax++import qualified Database.Relational.Record as Record+import Database.Relational.Projectable (PlaceHolders, SqlContext)+import Database.Relational.Monad.Class (MonadRestrict(..))+import Database.Relational.Monad.Trans.Restricting+  (Restrictings, restrictings, extractRestrict)+import Database.Relational.Monad.Trans.Aggregating+  (extractAggregateTerms, AggregatingSetT, PartitioningSet)+import Database.Relational.Monad.Trans.Ordering+  (Orderings, extractOrderingTerms)+import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig)+import Database.Relational.Monad.Type (QueryCore, extractCore, OrderedQuery)+++-- | Aggregated query monad type.+type QueryAggregate     = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore))++-- | Aggregated query type. 'AggregatedQuery' p r == 'QueryAggregate' ('PlaceHolders' p, 'Record' 'Aggregated' r).+type AggregatedQuery p r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) p r++-- | Partition monad type for partition-by clause.+type Window           c = Orderings c (PartitioningSet c)++-- | Restricted 'MonadRestrict' instance.+instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where+  restrict = restrictings . restrict++extract :: AggregatedQuery p r+        -> ConfigureQuery (((((((PlaceHolders p, Record Aggregated r), [OrderingTerm]),+                               [Predicate Aggregated]),+                              [AggregateElem]),+                             [Predicate Flat]),+                            JoinProduct), Duplication)+extract =  extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms++-- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation.+toSQL :: AggregatedQuery p r   -- ^ 'AggregatedQuery' to run+      -> ConfigureQuery String -- ^ Result SQL string with 'ConfigureQuery' computation+toSQL =  fmap Syntax.toSQL . toSubQuery++-- | Run 'AggregatedQuery' to get 'SubQuery' with 'ConfigureQuery' computation.+toSubQuery :: AggregatedQuery p r       -- ^ 'AggregatedQuery' to run+           -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation+toSubQuery q = do+  (((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q+  c <- askConfig+  return $ aggregatedSubQuery c (Record.untype pj) da pd rs ag grs ot++extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef])+extractWindow =  runIdentity . extractAggregateTerms . extractOrderingTerms++-- | Operator to make record of window function result using built 'Window' monad.+over :: SqlContext c+     => Record OverWindow a+     -> Window c ()+     -> Record c a+wp `over` win =+  Record.unsafeFromSqlTerms+  [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot)+  | c <- Record.columns wp+  ]  where (((), ot), pt) = extractWindow win++infix 8 `over`

@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Assign+-- Copyright   : 2013-2017 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.Monad.Assign (+  -- * Monad to restrict target records with assignment.+  Assign, AssignStatement,+  -- updateStatement,+  extract,+  ) where++import Database.Relational.Internal.Config (Config)+import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax+  (Predicate, Record, Assignment)++import Database.Relational.Table (Table)+import Database.Relational.Monad.Restrict (Restrict)+import qualified Database.Relational.Monad.Restrict as Restrict+import Database.Relational.Monad.Trans.Assigning (Assignings, extractAssignments)+++-- | Target update monad type used from update statement and merge statement.+type Assign r = Assignings r Restrict++-- | AssignStatement type synonym.+--   Specifying assignments and restrictions like update statement.+--   Record type must be+--   the same as 'Target' type parameter 'r'.+type AssignStatement r a = Record Flat r -> Assign r a++-- -- | 'return' of 'Update'+-- updateStatement :: a -> Assignings r (Restrictings Identity) a+-- updateStatement =  assignings . restrictings . Identity++-- | Run 'Assign'.+extract :: Assign r a -> Config -> ((a, Table r -> [Assignment]), [Predicate Flat])+extract =  Restrict.extract . extractAssignments

@@ -0,0 +1,95 @@+-- |+-- Module      : Database.Relational.Monad.BaseType+-- Copyright   : 2015-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines base monad type to build queries.+module Database.Relational.Monad.BaseType+       ( -- * Base monad type to build queries+         ConfigureQuery, configureQuery,+         qualifyQuery, askConfig,++         -- * Relation type+         Relation, unsafeTypeRelation, untypeRelation, relationWidth,++         dump,+         sqlFromRelationWith, sqlFromRelation,++         rightPh, leftPh,+       ) where++import Data.Functor.Identity (Identity, runIdentity)+import Control.Applicative ((<$>))++import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth)++import Database.Relational.Internal.String (StringSQL, showStringSQL)+import Database.Relational.Internal.Config (Config, defaultConfig)+import Database.Relational.SqlSyntax (Qualified, SubQuery, showSQL, width)++import qualified Database.Relational.Monad.Trans.Qualify as Qualify+import Database.Relational.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime)+import Database.Relational.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig)++-- | Thin monad type for untyped structure.+type ConfigureQuery = Qualify (QueryConfig Identity)++-- | Run 'ConfigureQuery' monad with initial state to get only result.+configureQuery :: ConfigureQuery q -> Config -> q+configureQuery cq c = runIdentity $ runQueryConfig (evalQualifyPrime cq) c++-- | Get qualifyed table form query.+qualifyQuery :: a -> ConfigureQuery (Qualified a)+qualifyQuery =  Qualify.qualifyQuery++-- | Read configuration.+askConfig :: ConfigureQuery Config+askConfig =  qualify askQueryConfig+++-- | Relation type with place-holder parameter 'p' and query result type 'r'.+newtype Relation p r = SubQuery (ConfigureQuery SubQuery)++-- | Unsafely type qualified subquery into record typed relation type.+unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r+unsafeTypeRelation = SubQuery++-- | Sub-query Qualify monad from relation.+untypeRelation :: Relation p r -> ConfigureQuery SubQuery+untypeRelation (SubQuery qsub) = qsub++-- | 'PersistableRecordWidth' of 'Relation' type.+relationWidth :: Relation p r ->  PersistableRecordWidth r+relationWidth rel =+  unsafePersistableRecordWidth . width $ configureQuery (untypeRelation rel) defaultConfig+  ---                               Assume that width is independent from Config structure++unsafeCastPlaceHolder :: Relation a r -> Relation b r+unsafeCastPlaceHolder (SubQuery qsub) = SubQuery qsub++-- | 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++-- | Generate SQL string from 'Relation' with configuration.+sqlFromRelationWith :: Relation p r -> Config -> StringSQL+sqlFromRelationWith =  configureQuery . (showSQL <$>) . untypeRelation++-- | SQL string from 'Relation'.+sqlFromRelation :: Relation p r -> StringSQL+sqlFromRelation =  (`sqlFromRelationWith` defaultConfig)++-- | Dump internal structure tree.+dump :: Relation p r -> String+dump =  show . (`configureQuery` defaultConfig) . untypeRelation++instance Show (Relation p r) where+  show = showStringSQL . sqlFromRelation

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Class+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines query building interface classes.+module Database.Relational.Monad.Class+       ( -- * Query interface classes+         MonadQualify (..), MonadRestrict (..),+         MonadQuery (..), MonadAggregate (..), MonadPartition (..),++         all', distinct,+         on, wheres, having,+       ) where++import Database.Relational.Internal.ContextType (Flat, Aggregated)+import Database.Relational.SqlSyntax+  (Duplication (..), Predicate, Record, AggregateKey)++import Database.Relational.Projectable (PlaceHolders)+import Database.Relational.Monad.BaseType (ConfigureQuery, Relation)+++-- | Restrict context interface+class (Functor m, Monad m) => MonadRestrict c m where+  -- | Add restriction to this context.+  restrict :: Predicate c -- ^ 'Record' which represent restriction+           -> m ()        -- ^ Restricted query context++-- | Query building interface.+class (Functor m, Monad m, MonadQualify ConfigureQuery m) => MonadQuery m where+  -- | Specify duplication.+  setDuplication :: Duplication -> m ()+  -- | Add restriction to last join.+  restrictJoin :: Predicate Flat -- ^ 'Record' which represent restriction+               -> m ()           -- ^ Restricted query context+  {- Haddock BUG? -}+  -- | Join sub-query with place-holder parameter 'p'. query result is not 'Maybe'.+  query' :: Relation p r+         -> m (PlaceHolders p, Record Flat r)+  -- | Join sub-query with place-holder parameter 'p'. Query result is 'Maybe'.+  queryMaybe' :: Relation p r+              -> m (PlaceHolders p, Record Flat (Maybe r))++-- | Lift interface from base qualify monad.+class (Functor q, Monad q, Functor m, Monad m) => MonadQualify q m where+  -- | Lift from qualify monad 'q' into 'MonadQuery' m.+  --   Qualify monad qualifies table form 'SubQuery'.+  liftQualify :: q a -> m a++instance (Functor q, Monad q) => MonadQualify q q where+  liftQualify = id++-- | Aggregated query building interface extends 'MonadQuery'.+class MonadQuery m => MonadAggregate m where+  -- | Add /GROUP BY/ term into context and get aggregated record.+  groupBy :: Record Flat r           -- ^ Record to add into group by+          -> m (Record Aggregated r) -- ^ Result context and aggregated record+  -- | Add /GROUP BY/ term into context and get aggregated record. Non-traditional group-by version.+  groupBy' :: AggregateKey (Record Aggregated r)  -- ^ Key to aggretate for non-traditional group-by interface+           -> m (Record Aggregated r)             -- ^ Result context and aggregated record++-- | Window specification building interface.+class Monad m => MonadPartition c m where+  -- | Add /PARTITION BY/ term into context.+  partitionBy :: Record c r -> m ()++-- | Specify ALL attribute to query context.+all' :: MonadQuery m => m ()+all' =  setDuplication All++-- | Specify DISTINCT attribute to query context.+distinct :: MonadQuery m => m ()+distinct =  setDuplication Distinct++-- | Add restriction to last join. Record type version.+on :: MonadQuery m => Predicate Flat -> m ()+on =  restrictJoin++-- | Add restriction to this not aggregated query.+wheres :: MonadRestrict Flat m => Predicate Flat -> m ()+wheres =  restrict++-- | Add restriction to this aggregated query. Aggregated Record type version.+having :: MonadRestrict Aggregated m => Predicate Aggregated -> m ()+having =  restrict

@@ -0,0 +1,31 @@+-- |+-- Module      : Database.Relational.Monad.Register+-- Copyright   : 2015-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module contains definitions about assignment monad type to build insert statement.+module Database.Relational.Monad.Register (+  -- * Monad to register target records.+  Register,++  extract,+  ) where++import Database.Relational.Internal.Config (Config)+import Database.Relational.SqlSyntax (Assignment)++import Database.Relational.Table (Table)+import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery)+import Database.Relational.Monad.Trans.Assigning (Assignings, extractAssignments)+++-- | Target register monad type used from insert statement.+type Register r = Assignings r ConfigureQuery++-- | Run 'InsertStatement'.+extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> [Assignment])+extract = configureQuery . extractAssignments

@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Restrict+-- Copyright   : 2013-2017 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.Monad.Restrict (+  -- * Monad to restrict target records.+  Restrict, RestrictedStatement,++  -- restricted,+  extract+  ) where++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.Internal.Config (Config)+import Database.Relational.SqlSyntax (Predicate, Record)++import Database.Relational.Monad.Trans.Restricting+  (Restrictings, extractRestrict)+import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery)+++-- | Restrict only monad type used from update statement and delete statement.+type Restrict = Restrictings Flat ConfigureQuery++-- | RestrictedStatement type synonym.+--   Record type 'r' must be+--   the same as 'Restrictings' type parameter 'r'.+type RestrictedStatement r a = Record Flat r -> Restrict a++-- -- | 'return' of 'Restrict'+-- restricted :: a -> Restrict a+-- restricted =  restrict . Identity++-- | Run 'Restrict' to get 'QueryRestriction'.+extract :: Restrict a -> Config -> (a, [Predicate Flat])+extract =  configureQuery . extractRestrict

@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Simple+-- Copyright   : 2013-2017 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.Monad.Simple (+  -- * Simple query+  QuerySimple, SimpleQuery,++  simple,++  toSQL,+  toSubQuery,+  ) where++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax+  (Duplication, OrderingTerm, JoinProduct, Predicate,  Record,+   SubQuery, flatSubQuery, )+import qualified Database.Relational.SqlSyntax as Syntax++import qualified Database.Relational.Record as Record+import Database.Relational.Monad.Trans.Join (join')+import Database.Relational.Monad.Trans.Restricting (restrictings)+import Database.Relational.Monad.Trans.Ordering+  (Orderings, orderings, extractOrderingTerms)+import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig)+import Database.Relational.Monad.Type (QueryCore, extractCore, OrderedQuery)+import Database.Relational.Projectable (PlaceHolders)+++-- | Simple (not-aggregated) query monad type.+type QuerySimple = Orderings Flat QueryCore++-- | Simple (not-aggregated) query type. 'SimpleQuery'' p r == 'QuerySimple' ('PlaceHolders' p, 'Record' r).+type SimpleQuery p r = OrderedQuery Flat QueryCore p r++-- | Lift from qualified table forms into 'QuerySimple'.+simple :: ConfigureQuery a -> QuerySimple a+simple =  orderings . restrictings . join'++extract :: SimpleQuery p r+        -> ConfigureQuery (((((PlaceHolders p, Record Flat r), [OrderingTerm]), [Predicate Flat]),+                           JoinProduct), Duplication)+extract =  extractCore . extractOrderingTerms++-- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation.+toSQL :: SimpleQuery p r         -- ^ 'SimpleQuery' to run+      -> ConfigureQuery String -- ^ Result SQL string with 'Qualify' computation+toSQL =  fmap Syntax.toSQL . toSubQuery++-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation.+toSubQuery :: SimpleQuery p r        -- ^ 'SimpleQuery'' to run+           -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation+toSubQuery q = do+   (((((_ph, pj), ot), rs), pd), da) <- extract q+   c <- askConfig+   return $ flatSubQuery c (Record.untype pj) da pd rs ot

@@ -0,0 +1,170 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Aggregating+-- Copyright   : 2013-2017 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.Monad.Trans.Aggregating+       ( -- * Transformer into aggregated query+         Aggregatings, aggregatings,++         AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT,++         -- * Result+         extractAggregateTerms,++         -- * Grouping sets support+         AggregatingSet, AggregatingPowerSet,  AggregatingSetList, PartitioningSet,+         key, key', set,+         bkey, rollup, cube, groupingSets,+       ) where++import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Control.Applicative (Applicative, pure, (<$>))+import Control.Arrow (second)+import Data.DList (DList, toList)++import Data.Functor.Identity (Identity (runIdentity))++import Database.Relational.Internal.ContextType+  (Flat, Aggregated, Set, Power, SetList)+import Database.Relational.SqlSyntax+  (Record,+   AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet,+   AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets,+   AggregateKey, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey)++import qualified Database.Relational.Record as Record+import Database.Relational.Monad.Class+  (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..))+++-- | Type to accumulate aggregating context.+--   Type 'ac' is aggregating-context type like aggregating key set building,+--   aggregating key sets set building and partition key set building.+--   Type 'at' is aggregating term type.+newtype Aggregatings ac at m a =+  Aggregatings (WriterT (DList at) m a)+  deriving (MonadTrans, Monad, Functor, Applicative)++-- | 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++-- | Context type building partition keys set.+type PartitioningSetT c   = Aggregatings c         AggregateColumnRef++-- | Aggregated 'MonadRestrict'.+instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where+  restrict =  aggregatings . restrict++-- | Aggregated 'MonadQualify'.+instance MonadQualify q m => MonadQualify q (AggregatingSetT m) where+  liftQualify = aggregatings . liftQualify++-- | Aggregated 'MonadQuery'.+instance MonadQuery m => MonadQuery (AggregatingSetT m) where+  setDuplication     = aggregatings . setDuplication+  restrictJoin       = aggregatings . restrictJoin+  query'             = aggregatings . query'+  queryMaybe'        = aggregatings . queryMaybe'++unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m ()+unsafeAggregateWithTerm =  Aggregatings . tell . pure++aggregateKey :: Monad m => AggregateKey a -> Aggregatings ac AggregateElem m a+aggregateKey k = do+  unsafeAggregateWithTerm $ aggregateKeyElement k+  return $ aggregateKeyRecord k++-- | Aggregated query instance.+instance MonadQuery m => MonadAggregate (AggregatingSetT m) where+  groupBy p = do+    mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Record.columns p]+    return $ Record.unsafeToAggregated p+  groupBy'  = aggregateKey++-- | Partition clause instance+instance Monad m => MonadPartition c (PartitioningSetT c m) where+  partitionBy =  mapM_ unsafeAggregateWithTerm . Record.columns++-- | Run 'Aggregatings' to get terms list.+extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at])+extractAggregateTerms (Aggregatings ac) = second toList <$> runWriterT ac++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++-- | Context monad type to build partition keys set.+type PartitioningSet c   = PartitioningSetT c   Identity++-- | Specify key of single grouping set from Record.+key :: Record Flat r+    -> AggregatingSet (Record Aggregated (Maybe r))+key p = do+  mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Record.columns p]+  return . Record.just $ Record.unsafeToAggregated p++-- | Specify key of single grouping set.+key' :: AggregateKey a+     -> AggregatingSet a+key' = aggregateKey++-- | 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 :: Record Flat r+     -> AggregatingPowerSet (Record Aggregated (Maybe r))+bkey p = do+  unsafeAggregateWithTerm . aggregatePowerKey $ Record.columns p+  return . Record.just $ Record.unsafeToAggregated p++finalizePower :: ([AggregateBitKey] -> AggregateElem)+              -> AggregatingPowerSet a -> AggregateKey a+finalizePower finalize pow = unsafeAggregateKey . 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 =  unsafeAggregateKey . second aggregateSets . extractTermList

@@ -0,0 +1,84 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Assigning+-- Copyright   : 2013-2017 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.Monad.Trans.Assigning (+  -- * Transformer into context with assignments+  Assignings, assignings,++  -- * API of context with assignments+  assignTo, (<-#), AssignTarget,++  -- * Result SQL set clause+  extractAssignments+  ) where++import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Control.Applicative (Applicative, pure, (<$>))+import Control.Arrow (second)+import Data.Monoid (mconcat)+import Data.DList (DList, toList)++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax (Record, Assignment)++import Database.Relational.Pi (Pi)+import Database.Relational.Table (Table, recordWidth)+import qualified Database.Relational.Record as Record+import Database.Relational.Monad.Class (MonadQualify (..), MonadRestrict(..))+++-- | Type to accumulate assigning context.+--   Type 'r' is table record type.+newtype Assignings r m a =+  Assignings (WriterT (Table r -> DList Assignment) m a)+  deriving (MonadTrans, Monad, Functor, Applicative)++-- | Lift to 'Assignings'+assignings :: Monad m => m a -> Assignings r m a+assignings =  lift++-- | 'MonadRestrict' with assigning.+instance MonadRestrict c m => MonadRestrict c (Assignings r m) where+  restrict = assignings . restrict++-- | 'MonadQualify' with assigning.+instance MonadQualify q m => MonadQualify q (Assignings r m) where+  liftQualify = assignings . liftQualify++-- | Target of assignment.+type AssignTarget r v = Pi r v++targetRecord :: AssignTarget r v ->  Table r -> Record Flat v+targetRecord pi' tbl = Record.wpi (recordWidth tbl) (Record.unsafeFromTable tbl) pi'++-- | Add an assignment.+assignTo :: Monad m => Record Flat v ->  AssignTarget r v -> Assignings r m ()+assignTo vp target = Assignings . tell+                     $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights  where+  leftsR = Record.columns . targetRecord target+  rights = Record.columns vp++-- | Add and assginment.+(<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m ()+(<-#) =  flip assignTo++infix 4 <-#++-- | Run 'Assignings' to get 'Assignments'+extractAssignments :: (Monad m, Functor m)+                   => Assignings r m a+                   -> m (a, Table r -> [Assignment])+extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac

@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Config+-- Copyright   : 2013-2017 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.Monad.Trans.Config (+  -- * Transformer into query with configuration+  QueryConfig, queryConfig,+  runQueryConfig, askQueryConfig+  ) where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import Control.Applicative (Applicative)++import Database.Relational.Internal.Config (Config)+++-- | 'ReaderT' type to require query generate configuration.+newtype QueryConfig m a =+  QueryConfig (ReaderT Config m a)+  deriving (Monad, Functor, Applicative)++-- | Run 'QueryConfig' to expand with configuration+runQueryConfig :: QueryConfig m a -> Config -> m a+runQueryConfig (QueryConfig r) = runReaderT r++-- | Lift to 'QueryConfig'.+queryConfig :: Monad m => m a -> QueryConfig m a+queryConfig =  QueryConfig . lift++-- | Read configuration.+askQueryConfig :: Monad m => QueryConfig m Config+askQueryConfig =  QueryConfig ask

@@ -0,0 +1,106 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Join+-- Copyright   : 2013-2017 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.Monad.Trans.Join+       ( -- * Transformer into join query+         QueryJoin, join',++         -- * Result+         extractProduct,++         -- * Unsafe API+         unsafeSubQueryWithAttr,+       ) where++import Prelude hiding (product)+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Control.Monad.Trans.State (modify, StateT, runStateT)+import Control.Applicative (Applicative, (<$>))+import Control.Arrow (second, (***))+import Data.Maybe (fromMaybe)+import Data.Monoid (Last (Last, getLast))++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax+  (Duplication (All), NodeAttr (Just', Maybe), Predicate, Record,+   SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, )++import Database.Relational.Monad.Trans.JoinState+  (JoinContext, primeJoinContext, updateProduct, joinProduct)+import qualified Database.Relational.Record as Record+import Database.Relational.Projectable (PlaceHolders, unsafeAddPlaceHolders)+import Database.Relational.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, untypeRelation)+import Database.Relational.Monad.Class (MonadQualify (..), MonadQuery (..))+++-- | 'StateT' type to accumulate join product context.+newtype QueryJoin m a =+  QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a)+  deriving (Monad, Functor, Applicative)++instance MonadTrans QueryJoin where+  lift = QueryJoin . lift . lift++-- | 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 => Predicate Flat -> 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 e++instance MonadQualify q m => MonadQualify q (QueryJoin m) where+  liftQualify = join' . liftQualify++-- | Joinable query instance.+instance MonadQuery (QueryJoin ConfigureQuery) where+  setDuplication     = QueryJoin . lift . tell . Last . Just+  restrictJoin       = updateJoinRestriction+  query'             = queryWithAttr Just'+  queryMaybe' pr     = do+    (ph, pj) <- queryWithAttr Maybe pr+    return (ph, Record.just pj)++-- | Unsafely join sub-query with this query.+unsafeSubQueryWithAttr :: Monad q+                       => NodeAttr                 -- ^ Attribute maybe or just+                       -> Qualified SubQuery       -- ^ 'SubQuery' to join+                       -> QueryJoin q (Record c r) -- ^ Result joined context and record of 'SubQuery' result.+unsafeSubQueryWithAttr attr qsub = do+  updateContext (updateProduct (`growProduct` (attr, qsub)))+  return $ Record.unsafeFromQualifiedSubQuery qsub++-- | Basic monadic join operation using 'MonadQuery'.+queryWithAttr :: NodeAttr+              -> Relation p r+              -> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)+queryWithAttr attr = unsafeAddPlaceHolders . run where+  run rel = do+    q <- liftQualify $ do+      sq <- untypeRelation rel+      qualifyQuery sq+    unsafeSubQueryWithAttr attr q++-- | Run 'QueryJoin' to get 'JoinProduct'+extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication)+extractProduct (QueryJoin s) = (second joinProduct *** (fromMaybe All . getLast))+                               <$> runWriterT (runStateT s primeJoinContext)

@@ -0,0 +1,45 @@+-- |+-- Module      : Database.Relational.Monad.Trans.JoinState+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides state definition for+-- "Database.Relational.Monad.Trans.Join".+--+-- This is not public interface.+module Database.Relational.Monad.Trans.JoinState (+  -- * Join context+  JoinContext, primeJoinContext, updateProduct, joinProduct+  ) where++import Prelude hiding (product)+import Data.DList (DList, toList)++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax (JoinProduct, Node, Predicate)+import qualified Database.Relational.SqlSyntax as Product+++-- | JoinContext type for QueryJoin.+newtype JoinContext =+  JoinContext+  { product  :: Maybe (Node (DList (Predicate Flat)))+  }++-- | Initial 'JoinContext'.+primeJoinContext :: JoinContext+primeJoinContext =  JoinContext Nothing++-- | Update product of 'JoinContext'.+updateProduct :: (Maybe (Node (DList (Predicate Flat))) -> Node (DList (Predicate Flat)))+              -> JoinContext+              -> JoinContext+updateProduct uf ctx = ctx { product = Just . uf . product $ ctx }++-- |  Finalize context to extract accumulated query product.+joinProduct :: JoinContext -> JoinProduct+joinProduct =  fmap (fmap toList . Product.nodeTree) . product

@@ -0,0 +1,113 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Ordering+-- Copyright   : 2013-2017 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.Monad.Trans.Ordering (+  -- * Transformer into query with ordering+  Orderings, orderings,++  -- * API of query with ordering+  orderBy', orderBy, asc, desc,++  -- * Result+  extractOrderingTerms+  ) where++import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Control.Applicative (Applicative, pure, (<$>))+import Control.Arrow (second)+import Data.DList (DList, toList)++import Database.Relational.SqlSyntax+  (Order (..), Nulls (..), OrderingTerm, Record)++import qualified Database.Relational.Record as Record+import Database.Relational.Monad.Class+  (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..))+++-- | Type to accumulate ordering context.+--   Type 'c' is ordering term record context type.+newtype Orderings c m a =+  Orderings (WriterT (DList OrderingTerm) m a)+  deriving (MonadTrans, Monad, Functor, Applicative)++-- | Lift to 'Orderings'.+orderings :: Monad m => m a -> Orderings c m a+orderings =  lift++-- | 'MonadRestrict' with ordering.+instance MonadRestrict rc m => MonadRestrict rc (Orderings c m) where+  restrict = orderings . restrict++-- | 'MonadQualify' with ordering.+instance MonadQualify q m => MonadQualify q (Orderings c m) where+  liftQualify = orderings . liftQualify++-- | 'MonadQuery' with ordering.+instance MonadQuery m => MonadQuery (Orderings c m) where+  setDuplication     = orderings . setDuplication+  restrictJoin       = orderings . restrictJoin+  query'             = orderings . query'+  queryMaybe'        = orderings . queryMaybe'++-- | 'MonadAggregate' with ordering.+instance MonadAggregate m => MonadAggregate (Orderings c m) where+  groupBy  = orderings . groupBy+  groupBy' = orderings . groupBy'++-- | 'MonadPartition' with ordering.+instance MonadPartition c m => MonadPartition c (Orderings c m) where+  partitionBy = orderings . partitionBy++-- | Add ordering terms.+updateOrderBys :: Monad m+               => (Order, Maybe Nulls) -- ^ Order direction+               -> Record c t       -- ^ Ordering terms to add+               -> Orderings c m ()     -- ^ Result context with ordering+updateOrderBys opair p = Orderings . mapM_ tell $ terms  where+  terms = curry pure opair `map` Record.columns p++-- | Add ordering terms with null ordering.+orderBy' :: Monad m+         => Record c t   -- ^ Ordering terms to add+         -> Order            -- ^ Order direction+         -> Nulls            -- ^ Order of null+         -> Orderings c m () -- ^ Result context with ordering+orderBy' p o n = updateOrderBys (o, Just n) p++-- | Add ordering terms.+orderBy :: Monad m+        => Record c t   -- ^ Ordering terms to add+        -> Order        -- ^ Order direction+        -> Orderings c m () -- ^ Result context with ordering+orderBy p o = updateOrderBys (o, Nothing) p++-- | Add ascendant ordering term.+asc :: Monad m+    => Record c t   -- ^ Ordering terms to add+    -> Orderings c m () -- ^ Result context with ordering+asc  =  updateOrderBys (Asc, Nothing)++-- | Add descendant ordering term.+desc :: Monad m+     => Record c t   -- ^ Ordering terms to add+     -> Orderings c m () -- ^ Result context with ordering+desc =  updateOrderBys (Desc, Nothing)++-- | Run 'Orderings' to get 'OrderingTerms'+extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, [OrderingTerm])+extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc

@@ -0,0 +1,54 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Qualify+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines monad transformer which qualify uniquely SQL table forms.+--+-- This is not public interface.+module Database.Relational.Monad.Trans.Qualify (+  -- * Qualify monad+  Qualify, qualify,+  evalQualifyPrime, qualifyQuery+  ) where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State (StateT, runStateT, get, modify)+import Control.Applicative (Applicative)+import Control.Monad (liftM, ap)++import qualified Database.Relational.SqlSyntax as Syntax+++-- | Monad type to qualify SQL table forms.+newtype Qualify m a =+  Qualify (StateT Int m a)+  deriving (Monad, Functor, Applicative)++-- | Run qualify monad with initial state to get only result.+evalQualifyPrime :: Monad m => Qualify m a -> m a+evalQualifyPrime (Qualify s) = fst `liftM` runStateT s 0 {- primary alias id -}++-- | Generated new qualifier on internal state.+newAlias :: Monad m => Qualify m Syntax.Qualifier+newAlias =  Qualify $ do+  ai <- Syntax.Qualifier `liftM` get+  modify (+ 1)+  return ai++-- | Lift to 'Qualify'+qualify :: Monad m => m a -> Qualify m a+qualify =  Qualify . lift++-- | Get qualifyed table form query.+qualifyQuery :: Monad m+             => query                                -- ^ Query to qualify+             -> Qualify m (Syntax.Qualified query) -- ^ Result with updated state+qualifyQuery query =+  Syntax.qualify `liftM` newAlias `ap` return query

@@ -0,0 +1,72 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Monad.Trans.Restricting+-- Copyright   : 2014-2017 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.Monad.Trans.Restricting (+  -- * Transformer into restricted context+  Restrictings, restrictings,++  -- * Result+  extractRestrict+  ) where++import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Control.Applicative (Applicative, pure, (<$>))+import Control.Arrow (second)+import Data.DList (DList, toList)++import Database.Relational.SqlSyntax (Predicate)++import Database.Relational.Monad.Class+  (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..))+++-- | Type to accumulate query restrictions.+--   Type 'c' is context tag of restriction building like+--   Flat (where) or Aggregated (having).+newtype Restrictings c m a =+  Restrictings (WriterT (DList (Predicate c)) m a)+  deriving (MonadTrans, Monad, Functor, Applicative)++-- | Lift to 'Restrictings'+restrictings :: Monad m => m a -> Restrictings c m a+restrictings =  lift++-- | Add whole query restriction.+updateRestriction :: Monad m => Predicate c -> Restrictings c m ()+updateRestriction =  Restrictings . tell . pure++-- | 'MonadRestrict' instance.+instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where+  restrict = updateRestriction++-- | Restricted 'MonadQualify' instance.+instance MonadQualify q m => MonadQualify q (Restrictings c m) where+  liftQualify = restrictings . liftQualify++-- | Restricted 'MonadQuery' instance.+instance MonadQuery q => MonadQuery (Restrictings c q) where+  setDuplication     = restrictings . setDuplication+  restrictJoin       = restrictings . restrictJoin+  query'             = restrictings . query'+  queryMaybe'        = restrictings . queryMaybe'++-- | Resticted 'MonadAggregate' instance.+instance MonadAggregate m => MonadAggregate (Restrictings c m) where+  groupBy  = restrictings . groupBy+  groupBy' = restrictings . groupBy'++-- | Run 'Restrictings' to get 'QueryRestriction'+extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, [Predicate c])+extractRestrict (Restrictings rc) = second toList <$> runWriterT rc

@@ -0,0 +1,37 @@+-- |+-- Module      : Database.Relational.Monad.Type+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines core query type.+module Database.Relational.Monad.Type+       ( -- * Core query monad+         QueryCore, extractCore,+         OrderedQuery,+       ) where++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax+  (Duplication, Record, JoinProduct, Predicate, )++import Database.Relational.Projectable (PlaceHolders)+import Database.Relational.Monad.BaseType (ConfigureQuery)+import Database.Relational.Monad.Trans.Join (QueryJoin, extractProduct)+import Database.Relational.Monad.Trans.Restricting (Restrictings, extractRestrict)+import Database.Relational.Monad.Trans.Ordering (Orderings)+++-- | 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, [Predicate Flat]), JoinProduct), Duplication)+extractCore =  extractProduct . extractRestrict++-- | OrderedQuery monad type with placeholder type 'p'. Record must be the same as 'Orderings' context type parameter 'c'.+type OrderedQuery c m p r = Orderings c m (PlaceHolders p, Record c r)

@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- |+-- Module      : Database.Relational.Monad.Unique+-- Copyright   : 2014-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module contains definitions about unique query type+-- to support scalar queries.+module Database.Relational.Monad.Unique+       ( QueryUnique, unsafeUniqueSubQuery,+         toSubQuery,+       ) where++import Control.Applicative (Applicative)++import Database.Relational.Internal.ContextType (Flat)+import Database.Relational.SqlSyntax+  (Duplication, Record, JoinProduct, NodeAttr,+   SubQuery, Predicate, Qualified, )++import qualified Database.Relational.Record as Record+import Database.Relational.Projectable (PlaceHolders)+import Database.Relational.Monad.Class (MonadQualify, MonadQuery)+import Database.Relational.Monad.Trans.Join (unsafeSubQueryWithAttr)+import Database.Relational.Monad.Trans.Restricting (restrictings)+import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig)+import Database.Relational.Monad.Type (QueryCore, extractCore)+import Database.Relational.SqlSyntax (flatSubQuery)+++-- | Unique query monad type.+newtype QueryUnique a = QueryUnique (QueryCore a)+                      deriving (MonadQualify ConfigureQuery, MonadQuery, Monad, Applicative, Functor)++-- | Unsafely join sub-query with this unique query.+unsafeUniqueSubQuery :: NodeAttr                 -- ^ Attribute maybe or just+                     -> Qualified SubQuery       -- ^ 'SubQuery' to join+                     -> QueryUnique (Record c r) -- ^ Result joined context and record of 'SubQuery' result.+unsafeUniqueSubQuery a  = QueryUnique . restrictings . unsafeSubQueryWithAttr a++extract :: QueryUnique a+        -> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication)+extract (QueryUnique c) = extractCore c++-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation.+toSubQuery :: QueryUnique (PlaceHolders p, Record c r) -- ^ 'QueryUnique' to run+           -> ConfigureQuery SubQuery                  -- ^ Result 'SubQuery' with 'Qualify' computation+toSubQuery q = do+  ((((_ph, pj), rs), pd), da) <- extract q+  c <- askConfig+  return $ flatSubQuery c (Record.untype pj) da pd rs []

@@ -0,0 +1,42 @@+-- |+-- Module      : Database.Relational.Pi+-- Copyright   : 2013-2017 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.Pi (+  -- * Projection path+  Pi, (<.>), (<?.>), (<?.?>),++  id', fst', snd'+  ) where++import qualified Control.Category as Category+import Database.Record+  (PersistableWidth, persistableWidth, PersistableRecordWidth)+import Database.Record.Persistable+  (runPersistableRecordWidth)++import Database.Relational.Pi.Unsafe+  (Pi, (<.>), (<?.>), (<?.?>), definePi)+++-- | Identity projection path.+id' :: Pi a a+id' = Category.id++-- | 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

@@ -0,0 +1,182 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.Relational.Pi.Unsafe+-- Copyright   : 2013-2017 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.Pi.Unsafe (+  -- * Projection path+  Pi,++  width', width,++  (<.>), (<?.>), (<?.?>),++  pi,++  definePi, defineDirectPi', defineDirectPi,++  unsafeExpandIndexes',+  unsafeExpandIndexes+  ) where++import Prelude hiding (pi, (.), id)+import Control.Category (Category (..), (>>>))+import Data.Array (listArray, (!))+import Data.Functor.ProductIsomorphic+  (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|),+   ProductIsoEmpty, pureE, peRight, peLeft, )++import Database.Record.Persistable+  (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth,+   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'.+newtype Pi r0 r1 = Pi { runPi :: PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1) }++instance PersistableWidth r0 => Show (Pi r0 r1) where+  show p = unwords ["Pi", show $ unsafeExpandIndexes p]++unsafePiAppend :: (PersistableRecordWidth b' -> PersistableRecordWidth b)+               -> (PersistableRecordWidth c' -> PersistableRecordWidth c)+               -> Pi a b' -> Pi b c' -> Pi a c+unsafePiAppend wbf wcf (Pi f) (Pi g) = Pi $ \wa ->+  let (pab, wb) = f wa+      (pbc, wc) = g $ wbf wb+  in (pab `unsafePiAppend'` pbc, wcf wc)++-- | Unsafely untype key to expand indexes.+unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int]+unsafeExpandIndexes' wa (Pi f) = d $ f wa where+  d (Map is, _)    = is+  d (Leftest i, w) = [ i .. i + w' - 1 ]  where+    w' = runPersistableRecordWidth w++-- | Unsafely untype key to expand indexes.+unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int]+unsafeExpandIndexes = unsafeExpandIndexes' persistableWidth++-- | Unsafely cast width proof object of record. Result record must be same width.+unsafeCastRecordWidth :: PersistableRecordWidth a -> PersistableRecordWidth a'+unsafeCastRecordWidth =  unsafePersistableRecordWidth . runPersistableRecordWidth++unsafeCast :: Pi a b' -> Pi a b+unsafeCast =  c  where+  d (Leftest i) = Leftest i+  d (Map m)     = Map m+  c (Pi f)    = Pi $ \wa ->+    let (pb, wb) = f wa in+    (d pb, unsafeCastRecordWidth wb)++-- | 'Pi' with zero width which projects to unit+pzero :: Pi a ()+pzero = Pi $ \_ -> (Map [], persistableWidth)++-- | Map projection path 'Pi' which has record result type.+instance ProductIsoFunctor (Pi a) where+  _ |$| p = unsafeCast p++-- | Compose projection path 'Pi' which has record result type using applicative style.+instance ProductIsoApplicative (Pi a) where+  pureP _ = unsafeCast pzero+  pab |*| pb =+    Pi $ \wr ->+           let (_, wab) = runPi pab wr+               (_, wb)  = runPi pb  wr in+             (Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb,+              wab |*| wb)++instance ProductIsoEmpty (Pi a) () where+  pureE   = pzero+  peRight = unsafeCast+  peLeft  = unsafeCast++-- | Get record width proof object.+width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct+width' (Pi f) = snd $ f persistableWidth++-- | Get record width.+width :: PersistableWidth r => Pi r a -> Int+width =  runPersistableRecordWidth . width'++justWidth :: PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a+justWidth = unsafeCastRecordWidth+++instance Category Pi where+  id = Pi $ \pw -> (Leftest 0, pw)+  Pi fb . Pi fa = Pi $ \wa ->+    let (pb, wb) = fa wa+        (pc, wc) = fb wb+    in (unsafePiAppend' pb pc, wc)++-- | Compose projection path.+(<.>) :: Pi a b -> Pi b c -> Pi a c+(<.>) = (>>>)++-- | Compose projection path. 'Maybe' phantom functor is 'map'-ed.+(<?.>) :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)+(<?.>) = unsafePiAppend justWidth maybeWidth++-- | Compose projection path. 'Maybe' phantom functors are 'join'-ed like '>=>'.+(<?.?>) :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c)+(<?.?>) = unsafePiAppend justWidth id++infixl 8 <.>, <?.>, <?.?>++-- | Unsafely project untyped value list.+pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a]+pi w0 (Pi f) cs = d p'  where+  (p', w1) = f w0+  d (Leftest i) = take (runPersistableRecordWidth w1) . 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 inferred '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 inferred 'PersistableRecordWidth'.+defineDirectPi :: PersistableWidth r1+               => [Int]    -- ^ Indexes of flat SQL value list+               -> Pi r0 r1 -- ^ Result projection path+defineDirectPi = defineDirectPi' persistableWidth

@@ -0,0 +1,539 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Database.Relational.Projectable+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines operators on various projected records.+module Database.Relational.Projectable (+  -- * Projectable from SQL strings+  SqlContext (unsafeProjectSqlTerms), unsafeProjectSql',+  unsafeProjectSql,++  -- * Records of values+  value,+  valueTrue, valueFalse,+  values,+  nothing,++  -- * Placeholders+  PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,+  pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH,++  -- * Projectable into SQL strings+  unsafeShowSql', unsafeShowSql,++  -- * Operators+  (.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.),++  and', or', in',++  (.||.), (?||?), like, likeMaybe, like', likeMaybe',+  (.+.), (.-.), (.*.), (./.),+  (?+?), (?-?), (?*?), (?/?),++  isNothing, isJust, fromMaybe,+  not', exists,++  negate', fromIntegral', showNum,+  negateMaybe, fromIntegralMaybe, showNumMaybe,++  casesOrElse, casesOrElse',+  caseSearch, caseSearchMaybe, case', caseMaybe,++  SqlBinOp, unsafeBinOp, unsafeUniOp,++  -- * Terms for Window function types+  rank, denseRank, rowNumber, percentRank, cumeDist,++  -- * Zipping projections+  projectZip, (><),++  -- * 'Maybe' type projecitoins+  ProjectableMaybe (just, flattenMaybe),+  ) where++import Prelude hiding (pi)++import Data.String (IsString)+import Data.Functor.ProductIsomorphic+  (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|),+   ProductIsoEmpty, pureE, peRight, peLeft, )++import Language.SQL.Keyword (Keyword)+import qualified Language.SQL.Keyword as SQL++import Database.Record+  (PersistableWidth, persistableWidth, PersistableRecordWidth,+   HasColumnConstraint, NotNull)+import Database.Record.Persistable (runPersistableRecordWidth)++import Database.Relational.Internal.ContextType+  (Flat, Aggregated, Exists, OverWindow)+import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL)+import Database.Relational.SqlSyntax (Record, Predicate)+import qualified Database.Relational.SqlSyntax as Syntax++import Database.Relational.Pure ()+import Database.Relational.TupleInstances ()+import Database.Relational.ProjectableClass+  (ShowConstantTermsSQL, showConstantTermsSQL, )+import Database.Relational.Record (RecordList)+import qualified Database.Relational.Record as Record+++-- | Interface to project SQL terms unsafely.+class SqlContext c where+  -- | Unsafely project from SQL expression terms.+  unsafeProjectSqlTerms :: [StringSQL]+                        -> Record c t++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext Flat where+  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext Aggregated where+  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms++-- | Unsafely make 'Record' from SQL terms.+instance SqlContext OverWindow where+  unsafeProjectSqlTerms = Record.unsafeFromSqlTerms++class SqlContext c => OperatorContext c+instance OperatorContext Flat+instance OperatorContext Aggregated+++-- | Unsafely Project single SQL term.+unsafeProjectSql' :: SqlContext c => StringSQL -> Record c t+unsafeProjectSql' = unsafeProjectSqlTerms . (:[])++-- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql'''.+unsafeProjectSql :: SqlContext c => String -> Record c t+unsafeProjectSql = unsafeProjectSql' . stringSQL++-- | Record with polymorphic phantom type of SQL null value. Semantics of comparing is unsafe.+nothing :: (OperatorContext c, SqlContext c, PersistableWidth a)+        => Record c (Maybe a)+nothing = proxyWidth persistableWidth+  where+    proxyWidth :: SqlContext c => PersistableRecordWidth a -> Record c (Maybe a)+    proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL++-- | Generate record with polymorphic type of SQL constant values from Haskell value.+value :: (ShowConstantTermsSQL t, OperatorContext c) => t -> Record c t+value = unsafeProjectSqlTerms . showConstantTermsSQL++-- | Record with polymorphic type of SQL true value.+valueTrue  :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)+valueTrue  =  just $ value True++-- | Record with polymorphic type of SQL false value.+valueFalse :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)+valueFalse =  just $ value False++-- | RecordList with polymorphic type of SQL set value from Haskell list.+values :: (ShowConstantTermsSQL t, OperatorContext c) => [t] -> RecordList (Record c) t+values =  Record.list . map value+++-- | Unsafely generate SQL expression term from record object.+unsafeShowSql' :: Record c a -> StringSQL+unsafeShowSql' = Record.unsafeStringSql++-- | Unsafely generate SQL expression string from record object.+--   String interface of 'unsafeShowSql''.+unsafeShowSql :: Record c a    -- ^ Source record object+              -> String -- ^ Result SQL expression string.+unsafeShowSql =  showStringSQL . unsafeShowSql'+++-- | Binary operator type for SQL String.+type SqlBinOp = Keyword -> Keyword -> Keyword++-- | Unsafely make unary operator for records from SQL keyword.+unsafeUniOp :: SqlContext c2+            => (Keyword -> Keyword) -> Record c1 a -> Record c2 b+unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql'++unsafeFlatUniOp :: SqlContext c+                => Keyword -> Record c a -> Record c b+unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw)++-- | Unsafely make binary operator for records from string binary operator.+unsafeBinOp :: SqlContext k+            => SqlBinOp+            -> Record k a -> Record k b -> Record k c+unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $+                     op (unsafeShowSql' a) (unsafeShowSql' b)++-- | Unsafely make binary operator to compare records from string binary operator.+compareBinOp :: SqlContext c+             => SqlBinOp+             -> Record c a -> Record c a -> Record c (Maybe Bool)+compareBinOp =  unsafeBinOp++-- | Unsafely make numrical binary operator for records from string binary operator.+monoBinOp :: SqlContext c+          => SqlBinOp+          -> Record c a -> Record c a -> Record c a+monoBinOp =  unsafeBinOp+++-- | Compare operator corresponding SQL /=/ .+(.=.)  :: OperatorContext c+       => Record c ft -> Record c ft -> Record c (Maybe Bool)+(.=.)  =  compareBinOp (SQL..=.)++-- | Compare operator corresponding SQL /</ .+(.<.)  :: OperatorContext c+       => Record c ft -> Record c ft -> Record c (Maybe Bool)+(.<.)  =  compareBinOp (SQL..<.)++-- | Compare operator corresponding SQL /<=/ .+(.<=.)  :: OperatorContext c+        => Record c ft -> Record c ft -> Record c (Maybe Bool)+(.<=.)  =  compareBinOp (SQL..<=.)++-- | Compare operator corresponding SQL />/ .+(.>.)  :: OperatorContext c+       => Record c ft -> Record c ft -> Record c (Maybe Bool)+(.>.)  =  compareBinOp (SQL..>.)++-- | Compare operator corresponding SQL />=/ .+(.>=.)  :: OperatorContext c+        => Record c ft -> Record c ft -> Record c (Maybe Bool)+(.>=.)  =  compareBinOp (SQL..>=.)++-- | Compare operator corresponding SQL /<>/ .+(.<>.) :: OperatorContext c+       => Record c ft -> Record c ft -> Record c (Maybe Bool)+(.<>.) =  compareBinOp (SQL..<>.)++-- | Logical operator corresponding SQL /AND/ .+and' :: OperatorContext c+     => Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool)+and' = monoBinOp SQL.and++-- | Logical operator corresponding SQL /OR/ .+or' :: OperatorContext c+    => Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool)+or'  = monoBinOp SQL.or++-- | Logical operator corresponding SQL /NOT/ .+not' :: OperatorContext c+     => Record c (Maybe Bool) -> Record c (Maybe Bool)+not' =  unsafeFlatUniOp SQL.NOT++-- | Logical operator corresponding SQL /EXISTS/ .+exists :: OperatorContext c+       => RecordList (Record Exists) r -> Record c (Maybe Bool)+exists =  unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS+          . Record.unsafeStringSqlList unsafeShowSql'++-- | Concatinate operator corresponding SQL /||/ .+(.||.) :: OperatorContext c+       => Record c a -> Record c a -> Record c a+(.||.) =  unsafeBinOp (SQL..||.)++-- | Concatinate operator corresponding SQL /||/ . Maybe type version.+(?||?) :: (OperatorContext c, IsString a)+       => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)+(?||?) =  unsafeBinOp (SQL..||.)++unsafeLike :: OperatorContext c+           => Record c a -> Record c b -> Record c (Maybe Bool)+unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE)++-- | String-compare operator corresponding SQL /LIKE/ .+like' :: (OperatorContext c, IsString a)+      => Record c a -> Record c a -> Record c (Maybe Bool)+x `like'` y = x `unsafeLike` y++-- | String-compare operator corresponding SQL /LIKE/ .+likeMaybe' :: (OperatorContext c, IsString a)+           => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe Bool)+x `likeMaybe'` y = x `unsafeLike` y++-- | String-compare operator corresponding SQL /LIKE/ .+like :: (OperatorContext c, IsString a, ShowConstantTermsSQL a)+       => Record c a -> a -> Record c (Maybe Bool)+x `like` a = x `like'` value a++-- | String-compare operator corresponding SQL /LIKE/ . Maybe type version.+likeMaybe :: (OperatorContext c, IsString a, ShowConstantTermsSQL a)+          => Record c (Maybe a) -> a -> Record c (Maybe Bool)+x `likeMaybe` a = x `unsafeLike` value a++-- | Unsafely make number binary operator for records from SQL operator string.+monoBinOp' :: SqlContext c+           => Keyword -> Record c a -> Record c a -> Record c a+monoBinOp' = monoBinOp . SQL.defineBinOp++-- | Number operator corresponding SQL /+/ .+(.+.) :: (OperatorContext c, Num a)+      => Record c a -> Record c a -> Record c a+(.+.) =  monoBinOp' "+"++-- | Number operator corresponding SQL /-/ .+(.-.) :: (OperatorContext c, Num a)+      => Record c a -> Record c a -> Record c a+(.-.) =  monoBinOp' "-"++-- | Number operator corresponding SQL /// .+(./.) :: (OperatorContext c, Num a)+      => Record c a -> Record c a -> Record c a+(./.) =  monoBinOp' "/"++-- | Number operator corresponding SQL /*/ .+(.*.) :: (OperatorContext c, Num a)+      => Record c a -> Record c a -> Record c a+(.*.) =  monoBinOp' "*"++-- | Number negate uni-operator corresponding SQL /-/.+negate' :: (OperatorContext c, Num a)+        => Record c a -> Record c a+negate' =  unsafeFlatUniOp $ SQL.word "-"++unsafeCastProjectable :: SqlContext c+                      => Record c a -> Record c b+unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql'++-- | Number fromIntegral uni-operator.+fromIntegral' :: (SqlContext c, Integral a, Num b)+              => Record c a -> Record c b+fromIntegral' =  unsafeCastProjectable++-- | Unsafely show number into string-like type in records.+showNum :: (SqlContext c, Num a, IsString b)+        => Record c a -> Record c b+showNum =  unsafeCastProjectable++-- | Number operator corresponding SQL /+/ .+(?+?) :: (OperatorContext c, Num a)+      => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)+(?+?) =  monoBinOp' "+"++-- | Number operator corresponding SQL /-/ .+(?-?) :: (OperatorContext c, Num a)+      => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)+(?-?) =  monoBinOp' "-"++-- | Number operator corresponding SQL /// .+(?/?) :: (OperatorContext c, Num a)+      => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)+(?/?) =  monoBinOp' "/"++-- | Number operator corresponding SQL /*/ .+(?*?) :: (OperatorContext c, Num a)+      => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)+(?*?) =  monoBinOp' "*"++-- | Number negate uni-operator corresponding SQL /-/.+negateMaybe :: (OperatorContext c, Num a)+            => Record c (Maybe a) -> Record c (Maybe a)+negateMaybe =  unsafeFlatUniOp $ SQL.word "-"++-- | Number fromIntegral uni-operator.+fromIntegralMaybe :: (SqlContext c, Integral a, Num b)+                  => Record c (Maybe a) -> Record c (Maybe b)+fromIntegralMaybe =  unsafeCastProjectable++-- | Unsafely show number into string-like type in records.+showNumMaybe :: (SqlContext c, Num a, IsString b)+             => Record c (Maybe a) -> Record c (Maybe b)+showNumMaybe = unsafeCastProjectable++-- | Search case operator correnponding SQL search /CASE/.+--   Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/+caseSearch :: OperatorContext c+           => [(Predicate c, Record c a)] -- ^ Each when clauses+           -> Record c a                            -- ^ Else result record+           -> Record c a                            -- ^ Result record+caseSearch = Syntax.caseSearch++-- | Same as 'caseSearch', but you can write like <when list> `casesOrElse` <else clause>.+casesOrElse :: OperatorContext c+            => [(Predicate c, Record c a)] -- ^ Each when clauses+            -> Record c a                            -- ^ Else result record+            -> Record c a                            -- ^ Result record+casesOrElse = caseSearch++-- | Null default version of 'caseSearch'.+caseSearchMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, PersistableWidth a)+                => [(Predicate c, Record c (Maybe a))] -- ^ Each when clauses+                -> Record c (Maybe a)                            -- ^ Result record+caseSearchMaybe cs = caseSearch cs nothing++-- | Simple case operator correnponding SQL simple /CASE/.+--   Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/+case' :: OperatorContext c+      => Record c a                 -- ^ Record value to match+      -> [(Record c a, Record c b)] -- ^ Each when clauses+      -> Record c b                 -- ^ Else result record+      -> Record c b                 -- ^ Result record+case' = Syntax.case'++-- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` <else clause>.+casesOrElse' :: OperatorContext c+             => (Record c a, [(Record c a, Record c b)]) -- ^ Record value to match and each when clauses list+             -> Record c b                               -- ^ Else result record+             -> Record c b                               -- ^ Result record+casesOrElse' =  uncurry case'++-- | Null default version of 'case''.+caseMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, PersistableWidth b)+          => Record c a                         -- ^ Record value to match+          -> [(Record c a, Record c (Maybe b))] -- ^ Each when clauses+          -> Record c (Maybe b)                 -- ^ Result record+caseMaybe v cs = case' v cs nothing++-- | Binary operator corresponding SQL /IN/ .+in' :: OperatorContext c+    => Record c t -> RecordList (Record c) t -> Record c (Maybe Bool)+in' a lp = unsafeProjectSql' . SQL.paren+           $ SQL.in' (unsafeShowSql' a) (Record.unsafeStringSqlList unsafeShowSql' lp)++-- | Operator corresponding SQL /IS NULL/ , and extended against record types.+isNothing :: (OperatorContext c, HasColumnConstraint NotNull r)+          => Record c (Maybe r) -> Predicate c+isNothing mr = unsafeProjectSql' $+               SQL.paren $ (SQL.defineBinOp SQL.IS)+               (Record.unsafeStringSqlNotNullMaybe mr) SQL.NULL++-- | Operator corresponding SQL /NOT (... IS NULL)/ , and extended against record type.+isJust :: (OperatorContext c, HasColumnConstraint NotNull r)+          => Record c (Maybe r) -> Predicate c+isJust =  not' . isNothing++-- | Operator from maybe type using record extended 'isNull'.+fromMaybe :: (OperatorContext c, HasColumnConstraint NotNull r)+          => Record c r -> Record c (Maybe r) -> Record c r+fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p++unsafeUniTermFunction :: SqlContext c => Keyword -> Record c t+unsafeUniTermFunction =  unsafeProjectSql' . (SQL.<++> stringSQL "()")++-- | /RANK()/ term.+rank :: Integral a => Record OverWindow a+rank =  unsafeUniTermFunction SQL.RANK++-- | /DENSE_RANK()/ term.+denseRank :: Integral a => Record OverWindow a+denseRank =  unsafeUniTermFunction SQL.DENSE_RANK++-- | /ROW_NUMBER()/ term.+rowNumber :: Integral a => Record OverWindow a+rowNumber =  unsafeUniTermFunction SQL.ROW_NUMBER++-- | /PERCENT_RANK()/ term.+percentRank :: Record OverWindow Double+percentRank =  unsafeUniTermFunction SQL.PERCENT_RANK++-- | /CUME_DIST()/ term.+cumeDist :: Record OverWindow Double+cumeDist =  unsafeUniTermFunction SQL.CUME_DIST++-- | Placeholder parameter type which has real parameter type arguemnt 'p'.+data PlaceHolders p = PlaceHolders++-- | Unsafely add placeholder parameter to queries.+unsafeAddPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a)+unsafeAddPlaceHolders =  fmap ((,) PlaceHolders)++-- | Unsafely get placeholder parameter+unsafePlaceHolders :: PlaceHolders p+unsafePlaceHolders =  PlaceHolders++-- | No placeholder semantics+unitPlaceHolder :: PlaceHolders ()+unitPlaceHolder = pureP ()++-- | No placeholder semantics. Same as `unitPlaceHolder`+unitPH :: PlaceHolders ()+unitPH = pureP ()++-- | Unsafely cast placeholder parameter type.+unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b+unsafeCastPlaceHolders PlaceHolders = PlaceHolders++-- | Provide scoped placeholder from width and return its parameter object.+pwPlaceholder :: SqlContext c+              => PersistableRecordWidth a+              -> (Record c a -> b)+              -> (PlaceHolders a, b)+pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw)+  where+    projectPlaceHolder :: SqlContext c+                       => PersistableRecordWidth a+                       -> Record c a+    projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth++-- | Provide scoped placeholder and return its parameter object.+placeholder' :: (PersistableWidth t, SqlContext c) => (Record c t -> a) ->  (PlaceHolders t, a)+placeholder' = pwPlaceholder persistableWidth++-- | Provide scoped placeholder and return its parameter object. Monadic version.+placeholder :: (PersistableWidth t, SqlContext c, Monad m) => (Record c t -> m a) -> m (PlaceHolders t, a)+placeholder f = do+  let (ph, ma) = placeholder' f+  a <- ma+  return (ph, a)+++-- | Zipping projections.+projectZip :: ProductIsoApplicative p => p a -> p b -> p (a, b)+projectZip pa pb = (,) |$| pa |*| pb++-- | Binary operator the same as 'projectZip'.+(><) :: ProductIsoApplicative p => p a -> p b -> p (a, b)+(><) = projectZip++-- | Interface to control 'Maybe' of phantom type in records.+class ProjectableMaybe p where+  -- | Cast record phantom type into 'Maybe'.+  just :: p a -> p (Maybe a)+  -- | Compose nested 'Maybe' phantom type on record.+  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 record type 'Record'.+instance ProjectableMaybe (Record c) where+  just         = Record.just+  flattenMaybe = Record.flattenMaybe++-- | Zipping except for identity element laws against placeholder parameter type.+instance ProductIsoEmpty PlaceHolders () where+  pureE   = unsafePlaceHolders+  peRight = unsafeCastPlaceHolders+  peLeft  = unsafeCastPlaceHolders++-- | Compose seed of record type 'PlaceHolders'.+instance ProductIsoFunctor PlaceHolders where+  _ |$| PlaceHolders = PlaceHolders++-- | Compose record type 'PlaceHolders' using applicative style.+instance ProductIsoApplicative PlaceHolders where+  pureP _   = unsafeCastPlaceHolders unitPH+  pf |*| pa = unsafeCastPlaceHolders (pf >< pa)++infixl 7 .*., ./., ?*?, ?/?+infixl 6 .+., .-., ?+?, ?-?+infixl 5 .||., ?||?+infix  4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'`+infixr 3 `and'`+infixr 2 `or'`+infixl 1  ><

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}++-- |+-- Module      : Database.Relational.ProjectableClass+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides interfaces to preserve constraints of+-- direct product projections.+module Database.Relational.ProjectableClass (+  -- * Literal SQL terms+  ShowConstantTermsSQL (..), showConstantTermsSQL,+  StringSQL,++  ) where++import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)+import Data.Monoid (mempty, (<>))+import Data.DList (DList, toList)++import Database.Relational.Internal.String (StringSQL)+++-- | Convert from haskell record to SQL terms list.+showConstantTermsSQL :: ShowConstantTermsSQL a+                     => a+                     -> [StringSQL]+showConstantTermsSQL = toList . showConstantTermsSQL'++{- |+'ShowConstantTermsSQL' 'a' is implicit rule to derive function to convert+from haskell record type 'a' into constant SQL terms.++Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#generic-programming>)+with default signature is available for 'ShowConstantTermsSQL' class,+so you can make instance like below:++@+  \{\-\# LANGUAGE DeriveGeneric \#\-\}+  import GHC.Generics (Generic)+  --+  data Foo = Foo { ... } deriving Generic+  instance ShowConstantTermsSQL Foo+@++-}+class ShowConstantTermsSQL a where+  showConstantTermsSQL' :: a -> DList StringSQL++  default showConstantTermsSQL' :: (Generic a, GShowConstantTermsSQL (Rep a)) => a -> DList StringSQL+  showConstantTermsSQL' = gShowConstantTermsSQL . from++class GShowConstantTermsSQL f where+  gShowConstantTermsSQL :: f a -> DList StringSQL++instance GShowConstantTermsSQL U1 where+  gShowConstantTermsSQL U1 = mempty++instance (GShowConstantTermsSQL a, GShowConstantTermsSQL b) =>+         GShowConstantTermsSQL (a :*: b) where+  gShowConstantTermsSQL (a :*: b) = gShowConstantTermsSQL a <> gShowConstantTermsSQL b++instance GShowConstantTermsSQL a => GShowConstantTermsSQL (M1 i c a) where+  gShowConstantTermsSQL (M1 a) = gShowConstantTermsSQL a++instance ShowConstantTermsSQL a => GShowConstantTermsSQL (K1 i a) where+  gShowConstantTermsSQL (K1 a) = showConstantTermsSQL' a

@@ -0,0 +1,168 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.Relational.ProjectableExtended+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines operators on various projected records.+module Database.Relational.ProjectableExtended (+  -- * Projection for nested 'Maybe's+  ProjectableFlattenMaybe (flatten),++  flattenPiMaybe,++  -- * Get narrower records+  (!), (?!), (?!?), (!??),++  -- * Aggregate functions+  unsafeAggregateOp,+  count,+  sum', sumMaybe, avg, avgMaybe,+  max', maxMaybe, min', minMaybe,+  every, any', some',+  )  where++import Prelude hiding (pi)++import qualified Language.SQL.Keyword as SQL+import Database.Record (PersistableWidth)++import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow)+import Database.Relational.SqlSyntax (Predicate, Record, )++import qualified Database.Relational.Record as Record+import Database.Relational.Projectable+  (unsafeUniOp, ProjectableMaybe (flattenMaybe), SqlContext)+import Database.Relational.Pi (Pi)+++class AggregatedContext ac+instance AggregatedContext Aggregated+instance AggregatedContext OverWindow++-- | Unsafely make aggregation uni-operator from SQL keyword.+unsafeAggregateOp :: (AggregatedContext ac, SqlContext ac)+                  => SQL.Keyword -> Record Flat a -> Record ac b+unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren)++-- | Aggregation function COUNT.+count :: (Integral b, AggregatedContext ac, SqlContext ac)+      => Record Flat a -> Record ac b+count =  unsafeAggregateOp SQL.COUNT++-- | Aggregation function SUM.+sumMaybe :: (Num a, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe a)+sumMaybe  =  unsafeAggregateOp SQL.SUM++-- | Aggregation function SUM.+sum' :: (Num a, AggregatedContext ac, SqlContext ac)+     => Record Flat a -> Record ac (Maybe a)+sum'  =  sumMaybe . Record.just++-- | Aggregation function AVG.+avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe b)+avgMaybe   =  unsafeAggregateOp SQL.AVG++-- | Aggregation function AVG.+avg :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac)+    => Record Flat a -> Record ac (Maybe b)+avg =  avgMaybe . Record.just++-- | Aggregation function MAX.+maxMaybe :: (Ord a, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe a)+maxMaybe  =  unsafeAggregateOp SQL.MAX++-- | Aggregation function MAX.+max' :: (Ord a, AggregatedContext ac, SqlContext ac)+     => Record Flat a -> Record ac (Maybe a)+max' =  maxMaybe . Record.just++-- | Aggregation function MIN.+minMaybe :: (Ord a, AggregatedContext ac, SqlContext ac)+         => Record Flat (Maybe a) -> Record ac (Maybe a)+minMaybe  =  unsafeAggregateOp SQL.MIN++-- | Aggregation function MIN.+min' :: (Ord a, AggregatedContext ac, SqlContext ac)+     => Record Flat a -> Record ac (Maybe a)+min' =  minMaybe . Record.just++-- | Aggregation function EVERY.+every :: (AggregatedContext ac, SqlContext ac)+      => Predicate Flat -> Record ac (Maybe Bool)+every =  unsafeAggregateOp SQL.EVERY++-- | Aggregation function ANY.+any' :: (AggregatedContext ac, SqlContext ac)+     => Predicate Flat -> Record ac (Maybe Bool)+any'  =  unsafeAggregateOp SQL.ANY++-- | Aggregation function SOME.+some' :: (AggregatedContext ac, SqlContext ac)+      => Predicate Flat -> Record ac (Maybe Bool)+some' =  unsafeAggregateOp SQL.SOME++-- | Get narrower record along with projection path.+(!) :: PersistableWidth a+    => Record c a -- ^ Source 'Record'+    -> Pi a b     -- ^ Record path+    -> Record c b -- ^ Narrower projected object+(!) = Record.pi++-- | Get narrower record along with projection path+--   'Maybe' phantom functor is 'map'-ed.+(?!) :: PersistableWidth a+     => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type+     -> Pi a b             -- ^ Record path+     -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result+(?!) = Record.piMaybe++-- | Get narrower record along with projection path+--   and project into result record type.+--   Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed.+(?!?) :: PersistableWidth a+      => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+      -> Pi a (Maybe b)     -- ^ Record path. 'Maybe' type leaf+      -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result+(?!?) = Record.piMaybe'+++-- | Interface to compose phantom 'Maybe' nested type.+class ProjectableFlattenMaybe a b where+  flatten :: ProjectableMaybe p => p a -> p b++-- | Compose 'Maybe' type in record 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 record with flatten leaf phantom Maybe types along with projection path.+flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)+               => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+               -> Pi a b                -- ^ Projection path+               -> Record cont c         -- ^ Narrower 'Record'. Flatten 'Maybe' phantom type+flattenPiMaybe p = flatten . Record.piMaybe p++-- | Get narrower record with flatten leaf phantom Maybe types along with projection path.+(!??) :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)+      => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type+      -> Pi a b                -- ^ Projection path+      -> Record cont c         -- ^ Narrower flatten and projected object.+(!??) = flattenPiMaybe+++infixl 8 !, ?!, ?!?, !??

@@ -0,0 +1,160 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module      : Database.Relational.Pure+-- Copyright   : 2013-2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines interfaces between haskell pure values+-- and query internal record values.+module Database.Relational.Pure () where++import Control.Applicative (pure)+import Data.Monoid ((<>))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import Text.Printf (PrintfArg, printf)+import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, formatTime)+import Data.Time.Locale.Compat (defaultTimeLocale)+import Data.DList (DList, fromList)++import Language.SQL.Keyword (Keyword (..))+import Database.Record+  (PersistableWidth, persistableWidth, PersistableRecordWidth)+import Database.Record.Persistable+  (runPersistableRecordWidth)++import Database.Relational.Internal.String (StringSQL, stringSQL, boolSQL)++import Database.Relational.ProjectableClass (ShowConstantTermsSQL (..))+++-- | Constant integral SQL terms.+intTermsSQL :: (Show a, Integral a) => a -> DList StringSQL+intTermsSQL =  pure . stringSQL . show++-- | Escape 'String' for constant SQL string expression.+escapeStringToSqlExpr :: String -> String+escapeStringToSqlExpr =  rec  where+  rec ""        = ""+  rec ('\'':cs) = '\'' : '\'' : rec cs+  rec (c:cs)    = c : rec cs++-- | From 'String' into constant SQL string expression.+stringExprSQL :: String -> StringSQL+stringExprSQL =  stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr++stringTermsSQL :: String -> DList StringSQL+stringTermsSQL = pure . stringExprSQL++-- | Constant SQL terms of '()'.+instance ShowConstantTermsSQL ()++-- | Constant SQL terms of 'Int8'.+instance ShowConstantTermsSQL Int8 where+  showConstantTermsSQL' = intTermsSQL++-- | Constant SQL terms of 'Int16'.+instance ShowConstantTermsSQL Int16 where+  showConstantTermsSQL' = intTermsSQL++-- | Constant SQL terms of 'Int32'.+instance ShowConstantTermsSQL Int32 where+  showConstantTermsSQL' = intTermsSQL++-- | Constant SQL terms of 'Int64'.+instance ShowConstantTermsSQL Int64 where+  showConstantTermsSQL' = intTermsSQL++-- | Constant SQL terms of 'Int'.+--   Use this carefully, because this is architecture dependent size of integer type.+instance ShowConstantTermsSQL Int where+  showConstantTermsSQL' = intTermsSQL++-- | Constant SQL terms of 'String'.+instance ShowConstantTermsSQL String where+  showConstantTermsSQL' = stringTermsSQL++-- | Constant SQL terms of 'ByteString'.+instance ShowConstantTermsSQL ByteString where+  showConstantTermsSQL' = stringTermsSQL . T.unpack . T.decodeUtf8++-- | Constant SQL terms of 'LB.ByteString'.+instance ShowConstantTermsSQL LB.ByteString where+  showConstantTermsSQL' = stringTermsSQL . LT.unpack . LT.decodeUtf8++-- | Constant SQL terms of 'Text'.+instance ShowConstantTermsSQL Text where+  showConstantTermsSQL' = stringTermsSQL . T.unpack++-- | Constant SQL terms of 'LT.Text'.+instance ShowConstantTermsSQL LT.Text where+  showConstantTermsSQL' = stringTermsSQL . LT.unpack++-- | Constant SQL terms of 'Char'.+instance ShowConstantTermsSQL Char where+  showConstantTermsSQL' = stringTermsSQL . (:"")++-- | Constant SQL terms of 'Bool'.+instance ShowConstantTermsSQL Bool where+  showConstantTermsSQL' = pure . boolSQL++floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL+floatTerms f = pure . stringSQL $ printf fmt f  where+  fmt+    | f >= 0    = "%f"+    | otherwise = "(%f)"++-- | Constant SQL terms of 'Float'. Caution for floating-point error rate.+instance ShowConstantTermsSQL Float where+  showConstantTermsSQL' = floatTerms++-- | Constant SQL terms of 'Double'. Caution for floating-point error rate.+instance ShowConstantTermsSQL Double where+  showConstantTermsSQL' = floatTerms++constantTimeTerms :: FormatTime t => Keyword -> String -> t -> DList StringSQL+constantTimeTerms kw fmt t = pure $ kw <> stringExprSQL (formatTime defaultTimeLocale fmt t)++-- | Constant SQL terms of 'Day'.+instance ShowConstantTermsSQL Day where+  showConstantTermsSQL' = constantTimeTerms DATE "%Y-%m-%d"++-- | Constant SQL terms of 'TimeOfDay'.+instance ShowConstantTermsSQL TimeOfDay where+  showConstantTermsSQL' = constantTimeTerms TIME "%H:%M:%S"++-- | Constant SQL terms of 'LocalTime'.+instance ShowConstantTermsSQL LocalTime where+  showConstantTermsSQL' = constantTimeTerms TIMESTAMP "%Y-%m-%d %H:%M:%S"++-- | Constant SQL terms of 'ZonedTime'.+--   This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal.+instance ShowConstantTermsSQL ZonedTime where+  showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"++-- | Constant SQL terms of 'UTCTime'.+--   This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal with UTC timezone.+instance ShowConstantTermsSQL UTCTime where+  showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z"++showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL+showMaybeTerms wa = d  where+  d (Just a) = showConstantTermsSQL' a+  d Nothing  = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"++-- | Constant SQL terms of 'Maybe' type. Width inference is required.+instance (PersistableWidth a, ShowConstantTermsSQL a)+         => ShowConstantTermsSQL (Maybe a) where+  showConstantTermsSQL' = showMaybeTerms persistableWidth

@@ -1,94 +1,19 @@ -- | -- Module      : Database.Relational.Query--- Copyright   : 2013-2017 Kei Hibino+-- Copyright   : 2017 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.Component,-  module Database.Relational.Query.Sub,-  module Database.Relational.Query.Projection,-  module Database.Relational.Query.ProjectableClass,-  module Database.Relational.Query.Projectable,-  module Database.Relational.Query.ProjectableExtended,-  module Database.Relational.Query.TupleInstances,-  module Database.Relational.Query.Monad.BaseType,-  module Database.Relational.Query.Monad.Class,-  module Database.Relational.Query.Monad.Trans.Ordering,-  module Database.Relational.Query.Monad.Trans.Aggregating,-  module Database.Relational.Query.Monad.Trans.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.Unique,-  module Database.Relational.Query.Monad.Assign,-  module Database.Relational.Query.Monad.Register,-  module Database.Relational.Query.Relation,-  module Database.Relational.Query.Scalar,-  module Database.Relational.Query.Type,-  module Database.Relational.Query.Effect,-  module Database.Relational.Query.Derives-  ) where--import Database.Relational.Query.Table (Table, TableDerivable (..))-import Database.Relational.Query.SQL (QuerySuffix, updateOtherThanKeySQL, insertSQL)-import Database.Relational.Query.Pure ()-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.Component-  (NameConfig (..), SchemaNameMode (..), ProductUnitSupport (..), IdentifierQuotation (..),-   Config (..), defaultConfig,-   AggregateKey, Order (..), Nulls (..))-import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth)-import Database.Relational.Query.Projection (Projection, list)-import Database.Relational.Query.ProjectableClass-import Database.Relational.Query.Projectable-import Database.Relational.Query.ProjectableExtended-import Database.Relational.Query.TupleInstances-import Database.Relational.Query.Monad.BaseType-import Database.Relational.Query.Monad.Class-  (MonadQualify,-   MonadRestrict, wheres, having, restrict,-   MonadAggregate, groupBy, groupBy',-   MonadQuery, query', queryMaybe',-   MonadPartition, partitionBy,-   distinct, all', on)-import Database.Relational.Query.Monad.Trans.Ordering (orderBy', orderBy, asc, desc)-import Database.Relational.Query.Monad.Trans.Aggregating-  (key, key', set, bkey, rollup, cube, groupingSets)-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, Window, over)-import Database.Relational.Query.Monad.Restrict (Restrict)-import Database.Relational.Query.Monad.Unique (QueryUnique)-import Database.Relational.Query.Monad.Assign (Assign)-import Database.Relational.Query.Monad.Register (Register)-import Database.Relational.Query.Relation-import Database.Relational.Query.Scalar (ScalarDegree)-import Database.Relational.Query.Type hiding-  (unsafeTypedKeyUpdate, unsafeTypedDelete,-   unsafeTypedInsert, unsafeTypedInsertQuery, )-import Database.Relational.Query.Effect-import Database.Relational.Query.Derives--import Database.Record.Instances ()+-- This module contains backword compatibility interface of+-- relational-query <= 0.9.*+module Database.Relational.Query+       {-# DEPRECATED "Should switch namespace to Database.Relational" #-}+       ( module Database.Relational,+         module Database.Relational.Compat,+       )  where -{-# ANN module "HLint: ignore Use import/export shortcut" #-}+import Database.Relational hiding (unsafeShowSql', unsafeShowSql, unsafeProjectSqlTerms, unsafeProjectSql)+import Database.Relational.Compat

@@ -1,448 +1,19 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- -- | -- Module      : Database.Relational.Query.Arrow--- Copyright   : 2015-2017 Kei Hibino+-- Copyright   : 2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com -- Stability   : experimental -- Portability : unknown ----- This module defines arrow version combinators which--- improves type-safty on building queries.--- Referencing the local projections may cause to break--- the result query.--- It is possible to controls injection of previous local projections--- by restricting domain type of arrow. This idea is imported from Opaleye:------   * <https://github.com/tomjaguarpaw/haskell-opaleye>---   * <https://github.com/khibino/haskell-relational-record/issues/19>------ Importing this module instead of "Database.Relational.Query" enables--- to build query using arrow combinators.-module Database.Relational.Query.Arrow (-  module Database.Relational.Query,--  all', distinct,--  query, queryMaybe, query', queryMaybe',-  queryList, queryList', queryExists, queryExists', queryListU, queryListU',-  queryScalar, queryScalar', queryScalarU, queryScalarU',--  uniqueQuery', uniqueQueryMaybe',--  on, wheres, having, groupBy, placeholder,--  relation, relation', aggregateRelation, aggregateRelation',--  uniqueRelation',--  groupBy', key, key', set, bkey, rollup, cube, groupingSets,--  orderBy', orderBy, asc, desc,--  partitionBy, over,--  assign,--  derivedUpdate', derivedUpdate,-  derivedInsertValue', derivedInsertValue,-  derivedDelete', derivedDelete,--  QueryA,--  QuerySimple, QueryAggregate, QueryUnique,--  AggregatingSet, AggregatingSetList, AggregatingPowerSet,--  Orderings, Window, Assignings,--  AssignStatement, Register, RestrictedStatement,-  ) where--import Control.Category (Category)-import Control.Arrow (Arrow, Kleisli (..))--import Database.Record--import Database.Relational.Query hiding-  (all', distinct,-   query, queryMaybe, query', queryMaybe',-   queryList, queryList', queryScalar, queryScalar',-   uniqueQuery', uniqueQueryMaybe',-   on, wheres, having, groupBy, placeholder,-   relation, relation', aggregateRelation, aggregateRelation', uniqueRelation',-   groupBy', key, key', set, bkey, rollup, cube, groupingSets,-   orderBy', orderBy, asc, desc, partitionBy, over,-   derivedUpdate', derivedUpdate,-   derivedInsertValue', derivedInsertValue,-   derivedDelete', derivedDelete,-   QuerySimple, QueryAggregate, QueryUnique, Window, Register)-import qualified Database.Relational.Query as Monadic-import Database.Relational.Query.Projection (ListProjection)-import qualified Database.Relational.Query.Monad.Trans.Aggregating as Monadic-import qualified Database.Relational.Query.Monad.Trans.Ordering as Monadic-import qualified Database.Relational.Query.Monad.Trans.Assigning as Monadic----- | Arrow to build queries.-newtype QueryA m a b = QueryA (Kleisli m a b) deriving (Category, Arrow)--queryA :: (a -> m b) -> QueryA m a b-queryA = QueryA . Kleisli--runQueryA :: QueryA m a b -> a -> m b-runQueryA (QueryA k) = runKleisli k--runAofM :: (m b -> c) -> QueryA m () b -> c-runAofM = (. (`runQueryA` ()))---- | Arrow type corresponding to 'Monadic.QuerySimple'-type QuerySimple    = QueryA Monadic.QuerySimple---- | Arrow type corresponding to 'Monadic.QueryAggregate'-type QueryAggregate = QueryA Monadic.QueryAggregate---- | Arrow type corresponding to 'Monadic.QueryUnique'-type QueryUnique = QueryA Monadic.QueryUnique---- | Arrow type corresponding to 'Monadic.AggregatingSet'-type AggregatingSet = QueryA Monadic.AggregatingSet---- | Arrow type corresponding to 'Monadic.AggregatingSetList'-type AggregatingSetList = QueryA Monadic.AggregatingSetList---- | Arrow type corresponding to 'Monadic.AggregatingPowerSet'-type AggregatingPowerSet = QueryA Monadic.AggregatingPowerSet---- | Arrow type corresponding to 'Monadic.Orderings'-type Orderings c m = QueryA (Monadic.Orderings c m)---- | Arrow type corresponding to 'Monadic.Window'-type Window c = QueryA (Monadic.Window c)---- | Arrow type corresponding to 'Monadic.Assignings'-type Assignings r m = QueryA (Monadic.Assignings r m)---- | Arrow type corresponding to 'Monadic.AssignStatement'-type AssignStatement r a = Assignings r Restrict (Projection Flat r) a---- | Arrow type corresponding to 'Monadic.Register'-type Register r a = QueryA (Monadic.Register r) () a---- | Arrow type corresponding to 'Monadic.RestrictedStatement'-type RestrictedStatement r a = QueryA Monadic.Restrict (Projection Flat r) a----- | Same as 'Monadic.all''. Arrow version.-all' :: MonadQuery m => QueryA m () ()-all' = queryA $ \() -> Monadic.all'---- | Same as 'Monadic.distinct'. Arrow version.-distinct :: MonadQuery m => QueryA m () ()-distinct = queryA $ \() -> Monadic.distinct---- | Same as 'Monadic.query'. Arrow version.---   The result arrow is not injected by local projections.-query :: (MonadQualify ConfigureQuery m, MonadQuery m)-      => Relation () r -> QueryA m () (Projection Flat r)-query r = queryA $ \() -> Monadic.query r---- | Same as 'Monadic.queryMaybe'. Arrow version.---   The result arrow is not injected by any local projections.-queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m)-           => Relation () r -> QueryA m () (Projection Flat (Maybe r))-queryMaybe r = queryA $ \() -> Monadic.queryMaybe r---- | Same as 'Monadic.query''. Arrow version.---   The result arrow is not injected by any local projections.-query' :: (MonadQualify ConfigureQuery m, MonadQuery m)-       => Relation p r -> QueryA m () (PlaceHolders p, Projection Flat r)-query' r = queryA $ \() -> Monadic.query' r---- | Same as 'Monadic.queryMaybe''. Arrow version.---   The result arrow is not injected by any local projections.-queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m)-            => Relation p r -> QueryA m () (PlaceHolders p, Projection Flat (Maybe r))-queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r--unsafeQueryList :: MonadQualify ConfigureQuery m-            => (a -> Relation () r)-            -> QueryA m a (ListProjection (Projection c) r)-unsafeQueryList rf = queryA $ Monadic.queryList . rf--unsafeQueryList' :: MonadQualify ConfigureQuery m-             => (a -> Relation p r)-             -> QueryA m a (PlaceHolders p, ListProjection (Projection c) r)-unsafeQueryList' rf = queryA $ Monadic.queryList' . rf---- | Same as 'Monadic.queryList'. Arrow version.---   The result arrow is designed to be injected by local projections.-queryList :: MonadQualify ConfigureQuery m-          => (Projection c a -> Relation () r)-          -> QueryA m (Projection c a) (ListProjection (Projection c) r)-queryList = unsafeQueryList---- | Same as 'Monadic.queryList''. Arrow version.---   The result arrow is designed to be injected by local projections.-queryList' :: MonadQualify ConfigureQuery m-           => (Projection c a -> Relation p r)-           -> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection c) r)-queryList' = unsafeQueryList'---- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version.---   The result arrow is designed to be injected by local projections.-queryExists :: MonadQualify ConfigureQuery m-          => (Projection c a -> Relation () r)-          -> QueryA m (Projection c a) (ListProjection (Projection Exists) r)-queryExists = unsafeQueryList---- | Same as 'Monadic.queryList'' to pass this result to 'exists' operator. Arrow version.---   The result arrow is designed to be injected by local projections.-queryExists' :: MonadQualify ConfigureQuery m-           => (Projection c a -> Relation p r)-           -> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection Exists) r)-queryExists' = unsafeQueryList'---- | Same as 'Monadic.queryList'. Arrow version.---   Useful for no reference cases to local projections.-queryListU :: MonadQualify ConfigureQuery m-           => Relation () r-           -> QueryA m () (ListProjection (Projection c) r)-queryListU r = unsafeQueryList $ \() -> r---- | Same as 'Monadic.queryList''. Arrow version.---   Useful for no reference cases to local projections.-queryListU' :: MonadQualify ConfigureQuery m-           => Relation p r-           -> QueryA m () (PlaceHolders p, ListProjection (Projection c) r)-queryListU' r = unsafeQueryList' $ \() -> r--unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)-                  => (a -> UniqueRelation () c r)-                  -> QueryA m a (Projection c (Maybe r))-unsafeQueryScalar rf = queryA $ Monadic.queryScalar . rf--unsafeQueryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)-                   => (a -> UniqueRelation p c r)-                   -> QueryA m a (PlaceHolders p, Projection c (Maybe r))-unsafeQueryScalar' rf = queryA $ Monadic.queryScalar' . rf---- | Same as 'Monadic.queryScalar'. Arrow version.---   The result arrow is designed to be injected by any local projection.-queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r)-            => (Projection c a -> UniqueRelation () c r)-            -> QueryA m (Projection c a) (Projection c (Maybe r))-queryScalar = unsafeQueryScalar---- | Same as 'Monadic.queryScalar''. Arrow version.---   The result arrow is designed to be injected by any local projection.-queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)-             => (Projection c a -> UniqueRelation p c r)-             -> QueryA m (Projection c a) (PlaceHolders p, Projection c (Maybe r))-queryScalar' = unsafeQueryScalar'---- | Same as 'Monadic.queryScalar'. Arrow version.---   Useful for no reference cases to local projections.-queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r)-            => UniqueRelation () c r-            -> QueryA m () (Projection c (Maybe r))-queryScalarU r = unsafeQueryScalar $ \() -> r---- | Same as 'Monadic.queryScalar''. Arrow version.---   Useful for no reference cases to local projections.-queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r)-             => UniqueRelation p c r-             -> QueryA m () (PlaceHolders p, Projection c (Maybe r))-queryScalarU' r = unsafeQueryScalar' $ \() -> r---- | Same as 'Monadic.uniqueQuery''. Arrow version.---   The result arrow is not injected by local projections.-uniqueQuery' :: UniqueRelation p c r-             -> QueryA Monadic.QueryUnique () (PlaceHolders p, Projection c r)-uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r---- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version.---   The result arrow is not injected by local projections.-uniqueQueryMaybe' :: UniqueRelation p c r-                  -> QueryA Monadic.QueryUnique () (PlaceHolders p, Projection c (Maybe r))-uniqueQueryMaybe' r = queryA $ \() -> Monadic.uniqueQueryMaybe' r---- | Same as 'Monadic.on'. Arrow version.---   The result arrow is designed to be injected by local conditional flat-projections.-on :: MonadQuery m-   => QueryA m (Projection Flat (Maybe Bool)) ()-on = queryA Monadic.on---- | Same as 'Monadic.wheres'. Arrow version.---   The result arrow is designed to be injected by local conditional flat-projections.-wheres :: MonadRestrict Flat m-       => QueryA m (Projection Flat (Maybe Bool)) ()-wheres = queryA Monadic.wheres---- | Same as 'Monadic.having'. Arrow version.---   The result arrow is designed to be injected by local conditional aggregated-projections.-having :: MonadRestrict Aggregated m-       => QueryA m (Projection Aggregated (Maybe Bool)) ()-having = queryA Monadic.having---- | Same as 'Monadic.groupBy'. Arrow version.---   The result arrow is designed to be injected by local flat-projections.-groupBy :: MonadAggregate m-        => QueryA m (Projection Flat r) (Projection Aggregated r)-groupBy = queryA Monadic.groupBy---- | Same as 'Monadic.placeholder'. Arrow version.---   The result arrow is designed to be injected by locally built arrow using placeholders.-placeholder :: (PersistableWidth t, SqlProjectable p, Monad m)-            => QueryA m (QueryA m (p t) a) (PlaceHolders t, a)-placeholder = queryA $ Monadic.placeholder . runQueryA---- | Same as 'Monadic.relation'.---   Finalize query-building arrow instead of query-building monad.-relation :: QuerySimple () (Projection Flat r)-         -> Relation () r-relation = runAofM Monadic.relation---- | Same as 'Monadic.relation''.---   Finalize query-building arrow instead of query-building monad.-relation' :: QuerySimple () (PlaceHolders p, Projection Flat r)-          -> Relation p r-relation' = runAofM Monadic.relation'---- | Same as 'Monadic.aggregateRelation'.---   Finalize query-building arrow instead of query-building monad.-aggregateRelation :: QueryAggregate () (Projection Aggregated r)-                  -> Relation () r-aggregateRelation = runAofM Monadic.aggregateRelation---- | Same as 'Monadic.aggregateRelation''.---   Finalize query-building arrow instead of query-building monad.-aggregateRelation' :: QueryAggregate () (PlaceHolders p, Projection Aggregated r)-                   -> Relation p r-aggregateRelation' = runAofM Monadic.aggregateRelation'---- | Same as 'Monadic.uniqueRelation''.---   Finalize query-building arrow instead of query-building monad.-uniqueRelation' :: QueryUnique () (PlaceHolders p, Projection c r)-                -> UniqueRelation p c r-uniqueRelation' = runAofM Monadic.uniqueRelation'---- | Same as 'Monadic.groupBy''.---   This arrow is designed to be injected by local 'AggregateKey'.-groupBy' :: MonadAggregate m => QueryA m (AggregateKey (Projection Aggregated r)) (Projection Aggregated r)-groupBy' = queryA Monadic.groupBy'---- | Same as 'Monadic.key'.---   This arrow is designed to be injected by local flat-projections.-key :: AggregatingSet (Projection Flat r) (Projection Aggregated (Maybe r))-key = queryA Monadic.key---- | Same as 'Monadic.key''.---   This arrow is designed to be injected by local 'AggregteKey'.-key' :: AggregatingSet (AggregateKey a) a-key' = queryA Monadic.key'---- | Same as 'Monadic.set'.---   This arrow is designed to be injected by locally built 'AggregtingSet' arrow.-set :: AggregatingSetList (AggregatingSet () a) a-set = queryA $ runAofM Monadic.set---- | Same as 'Monadic.bkey'.---   This arrow is designed to be injected by local flat-projections.-bkey :: AggregatingPowerSet (Projection Flat r) (Projection Aggregated (Maybe r))-bkey = queryA Monadic.bkey---- | Same as 'Monadic.rollup'.---   Finalize locally built 'AggregatingPowerSet'.-rollup :: AggregatingPowerSet () a -> AggregateKey a-rollup = runAofM Monadic.rollup---- | Same as 'Monadic.cube'.---   Finalize locally built 'AggregatingPowerSet'.-cube :: AggregatingPowerSet () a -> AggregateKey a-cube = runAofM Monadic.cube---- | Same as 'Monadic.groupingSets'.---   Finalize locally built 'AggregatingSetList'.-groupingSets :: AggregatingSetList () a -> AggregateKey a-groupingSets = runAofM Monadic.groupingSets---- | Same as 'Monadic.orderBy''.---   The result arrow is designed to be injected by local projections.-orderBy' :: Monad m-         => Order-         -> Nulls-         -> Orderings c m (Projection c t) ()-orderBy' o n = queryA $ \p -> Monadic.orderBy' p o n---- | Same as 'Monadic.orderBy'.---   The result arrow is designed to be injected by local projections.-orderBy :: Monad m-        => Order-        -> Orderings c m (Projection c t) ()-orderBy o = queryA (`Monadic.orderBy` o)---- | Same as 'Monadic.asc'.---   The result arrow is designed to be injected by local projections.-asc :: Monad m-    => Orderings c m (Projection c t) ()-asc = queryA Monadic.asc---- | Same as 'Monadic.desc'.---   The result arrow is designed to be injected by local projections.-desc :: Monad m-     => Orderings c m (Projection c t) ()-desc = queryA Monadic.desc---- | Same as 'Monadic.partitionBy'.---   The result arrow is designed to be injected by local projections.-partitionBy :: Window c (Projection c r) ()-partitionBy = queryA Monadic.partitionBy---- | Same as 'Monadic.over'.---   Make window function result projection using built 'Window' arrow.-over :: SqlProjectable (Projection c)-     => Projection OverWindow a -> Window c () () -> Projection c a-over po = runAofM $ Monadic.over po--infix 8 `over`---- | Make 'Monadic.AssignTarget' into arrow which is designed to be---   injected by local projection assignees.-assign :: Monad m-       => Monadic.AssignTarget r v-       -> Assignings r m (Projection Flat v) ()-assign t = queryA (`Monadic.assignTo` t)---- | Same as 'Monadic.derivedUpdate''.---   Make 'Update' from assigning statement arrow using configuration.-derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p-derivedUpdate' config = Monadic.derivedUpdate' config . runQueryA---- | Same as 'Monadic.derivedUpdate'.---   Make 'Update' from assigning statement arrow.-derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p-derivedUpdate = Monadic.derivedUpdate . runQueryA---- | Same as 'Monadic.derivedInsertValue''.---   Make 'Insert' from register arrow using configuration.-derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p-derivedInsertValue' config = Monadic.derivedInsertValue' config . ($ ()) . runQueryA---- | Same as 'Monadic.derivedInsertValue'.---   Make 'Insert' from register arrow.-derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p-derivedInsertValue = Monadic.derivedInsertValue . ($ ()) . runQueryA---- | Same as 'Monadic.derivedDelete''.---   Make 'Update' from restrict statement arrow using configuration.-derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p-derivedDelete' config = Monadic.derivedDelete' config . runQueryA+-- This module contains backword compatibility interface of+-- relational-query <= 0.9.*+module Database.Relational.Query.Arrow+       {-# DEPRECATED "Should switch namespace to Database.Relational.Arrow" #-}+       ( module Database.Relational.Arrow,+         module Database.Relational.Compat,+       )  where --- | Same as 'Monadic.derivedDelete'.---   Make 'Update' from restrict statement arrow.-derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p-derivedDelete = Monadic.derivedDelete . runQueryA+import Database.Relational.Arrow hiding (unsafeShowSql', unsafeShowSql, unsafeProjectSqlTerms, unsafeProjectSql)+import Database.Relational.Compat

@@ -1,85 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ConstraintKinds #-}---- |--- Module      : Database.Relational.Query.BaseTH--- Copyright   : 2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines templates for internally using.-module Database.Relational.Query.BaseTH (-  defineProductConstructorInstance,-  defineTupleProductConstructor,-  defineTupleShowConstantInstance,-  defineTuplePi,-  ) where--import Control.Applicative ((<$>))-import Data.List (foldl')-import Language.Haskell.TH-  (Q, Name, mkName, tupleDataName, normalB, classP, varP,-   TypeQ, forallT, arrowT, varT, tupleT, appT,-   Dec, sigD, valD, instanceD, ExpQ, conE,-   TyVarBndr (PlainTV), )-import Database.Record.Persistable-  (PersistableWidth, persistableWidth,-   PersistableRecordWidth, runPersistableRecordWidth)--import Database.Relational.Query.ProjectableClass-  (ProductConstructor (..), ShowConstantTermsSQL (..), )-import Database.Relational.Query.Pi.Unsafe (Pi, definePi)----- | Make template for 'ProductConstructor' instance.-defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]-defineProductConstructorInstance recTypeQ recData colTypes =-  [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where-        productConstructor = $(recData)-    |]--tupleN :: Int -> (([Name], [TypeQ]), TypeQ)-tupleN n = ((ns, vs), foldl' appT (tupleT n) vs)-  where-    ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]-    vs = map varT ns---- | Make template of ProductConstructor instance of tuple type.-defineTupleProductConstructor :: Int -> Q [Dec]-defineTupleProductConstructor n = do-  let ((_, vs), tty)  =  tupleN n-  defineProductConstructorInstance tty (conE $ tupleDataName n) vs---- | Make template of 'ShowConstantTermsSQL' instance of tuple type.-defineTupleShowConstantInstance :: Int -> Q [Dec]-defineTupleShowConstantInstance n = do-  let ((_, vs), tty)  =  tupleN n-  (:[]) <$> instanceD-    -- in template-haskell 2.8 or older, Pred is not Type-    (mapM (classP ''ShowConstantTermsSQL . (:[])) vs)-    [t| ShowConstantTermsSQL $tty |]-    []--tuplePi :: Int -> Int -> Q [Dec]-tuplePi n i = do-  let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"-      ((ns, vs), tty) = tupleN n-  sig <- sigD selN $-         forallT (map PlainTV ns)-         (mapM (classP ''PersistableWidth . (:[])) vs)-         [t| Pi $tty $(vs !! i) |]-  val <- valD (varP selN)-         (normalB [| definePi $(foldl'-                                (\e t -> [| $e + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |])-                                [| 0 :: Int |] $ take i vs) |])-         []-  return [sig, val]---- | Make templates of projection paths for tuple types.-defineTuplePi :: Int -> Q [Dec]-defineTuplePi n =-  concat <$> mapM (tuplePi n) [0 .. n - 1]

@@ -1,27 +0,0 @@--- |--- Module      : Database.Relational.Query.Component--- Copyright   : 2013-2017 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-       ( -- * Configuration type for query-         module Database.Relational.Query.Internal.Config,--         -- * Types for aggregation-         AggregateKey,--         -- * Types for ordering-         Order (..), Nulls (..),-       ) where--import Database.Relational.Query.Internal.Config-  (NameConfig (..),-   ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..),-   Config (..), defaultConfig,)-import Database.Relational.Query.Internal.BaseSQL (Order (..), Nulls (..),)-import Database.Relational.Query.Internal.GroupingSQL (AggregateKey)

@@ -1,113 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}---- |--- Module      : Database.Relational.Query.Constraint--- Copyright   : 2013-2017 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.Record (PersistableRecordWidth, PersistableWidth (persistableWidth))-import Database.Record.KeyConstraint-  (KeyConstraint, unsafeSpecifyKeyConstraint,-   Primary, Unique, NotNull)-import qualified Database.Record.KeyConstraint as C--import Database.Relational.Query.Pi (Pi)-import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi----- | 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---- | Inferred '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---- -- | Inferred '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

@@ -1,15 +0,0 @@--- |--- Module      : Database.Relational.Query.Context--- Copyright   : 2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module re-export query context tag types.-module Database.Relational.Query.Context-       ( module Database.Relational.Query.Internal.ContextType-       ) where--import Database.Relational.Query.Internal.ContextType

@@ -1,113 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}---- |--- Module      : Database.Relational.Query.Derives--- Copyright   : 2013-2017 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-  updateByConstraintKey,-  primaryUpdate,--  updateValuesWithKey,--  -- * Derived objects from table-  derivedUniqueRelation-  ) where--import Database.Record (PersistableWidth, ToSql (recordToSql))-import Database.Record.ToSql (unsafeUpdateValuesWithIndexes)--import Database.Relational.Query.Table (Table, TableDerivable)-import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes)-import Database.Relational.Query.Projection (Projection)-import qualified Database.Relational.Query.Projection as Projection-import Database.Relational.Query.Projectable (placeholder, (.=.))-import Database.Relational.Query.ProjectableExtended ((!))-import Database.Relational.Query.Monad.Class (wheres)-import Database.Relational.Query.Monad.BaseType (Relation, relationWidth)-import Database.Relational.Query.Relation-  (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique)-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)----- | 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 $ Projection.wpi (relationWidth rel) 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 inferred 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 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' = typedKeyUpdate table' . Constraint.projectionKey---- | Typed 'KeyUpdate' using inferred primary key.-primaryUpdate :: (HasConstraintKey Primary r p)-              => Table r       -- ^ 'Table' to update-              -> KeyUpdate p r -- ^ Result typed 'Update'-primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey)---- | 'UniqueRelation' inferred from table.-derivedUniqueRelation :: TableDerivable r-                      => Key Unique r k        -- ^ Unique key proof object which record type is 'a' and key type is 'p'.-                      -> Projection c k        -- ^ Unique key value to specify.-                      -> UniqueRelation () c r -- ^ Result restricted 'Relation'-derivedUniqueRelation uk kp = unsafeUnique . relation $ do-  r <- query derivedRelation-  wheres $ r ! projectionKey uk .=. Projection.unsafeChangeContext kp-  return r

@@ -1,190 +0,0 @@--- |--- Module      : Database.Relational.Query.Effect--- Copyright   : 2013-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines effect statements--- like update and delete.-module Database.Relational.Query.Effect (-  -- * Object to express simple restriction.-  Restriction, restriction, restriction',--  -- * Object to express update target columns and restriction.-  UpdateTarget, updateTarget, updateTarget',-  liftTargetAllColumn, liftTargetAllColumn',-  updateTargetAllColumn, updateTargetAllColumn',--  -- * Object to express insert terget.-  InsertTarget, insertTarget, insertTarget', piRegister,--  -- * Generate SQL from restriction.-  sqlWhereFromRestriction,-  sqlFromUpdateTarget,-  sqlChunkFromInsertTarget,-  sqlFromInsertTarget,-  ) where--import Data.Monoid ((<>))--import Language.SQL.Keyword (Keyword(..))-import Database.Record.Persistable (PersistableWidth)--import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig)-import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)-import Database.Relational.Query.Internal.BaseSQL (composeSets, composeChunkValuesWithColumns)--import Database.Relational.Query.Pi (Pi, id')-import qualified Database.Relational.Query.Pi.Unsafe as Pi-import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)-import qualified Database.Relational.Query.Table as Table-import Database.Relational.Query.Sub (composeWhere)-import qualified Database.Relational.Query.Projection as Projection-import Database.Relational.Query.Projectable-  (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders,-   pwPlaceholder, placeholder, (><), rightId)-import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#))-import Database.Relational.Query.Monad.Restrict (RestrictedStatement)-import qualified Database.Relational.Query.Monad.Restrict as Restrict-import Database.Relational.Query.Monad.Assign (AssignStatement)-import qualified Database.Relational.Query.Monad.Assign as Assign-import Database.Relational.Query.Monad.Register (Register)-import qualified Database.Relational.Query.Monad.Register as Register----- | Restriction type with place-holder parameter 'p' and projection record type 'r'.-newtype Restriction p r = Restriction (RestrictedStatement r (PlaceHolders p))---- | Finalize 'Restrict' monad and generate 'Restriction'.-restriction :: RestrictedStatement r () -> Restriction () r-restriction = Restriction . ((>> return unitPlaceHolder) .)---- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p'-restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r-restriction' = Restriction--runRestriction :: Restriction p r-               -> RestrictedStatement r (PlaceHolders p)-runRestriction (Restriction qf) =-  fmap fst . unsafeAddPlaceHolders . qf---- | SQL WHERE clause 'StringSQL' string from 'Restriction'.-sqlWhereFromRestriction :: Config -> Table r -> Restriction p r -> StringSQL-sqlWhereFromRestriction config tbl (Restriction q) = composeWhere rs-  where (_ph, rs) = Restrict.extract (q $ Projection.unsafeFromTable tbl) config---- | Show where clause.-instance TableDerivable r => Show (Restriction p r) where-  show = showStringSQL . sqlWhereFromRestriction defaultConfig derivedTable----- | UpdateTarget type with place-holder parameter 'p' and projection record type 'r'.-newtype UpdateTarget p r = UpdateTarget (AssignStatement r (PlaceHolders p))---- | Finalize 'Target' monad and generate 'UpdateTarget'.-updateTarget :: AssignStatement r ()-             -> UpdateTarget () r-updateTarget =  UpdateTarget . ((>> return unitPlaceHolder) .)---- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'.-updateTarget' :: AssignStatement r (PlaceHolders p)-              -> UpdateTarget p r-updateTarget' = UpdateTarget--_runUpdateTarget :: UpdateTarget p r-                 -> AssignStatement r (PlaceHolders p)-_runUpdateTarget (UpdateTarget qf) =-  fmap fst . unsafeAddPlaceHolders . qf--updateAllColumn :: PersistableWidth r-                => Restriction p r-                -> AssignStatement r (PlaceHolders (r, p))-updateAllColumn rs proj = do-  (ph0, ()) <- placeholder (\ph -> 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' $ \proj -> fmap rightId $ updateAllColumn rs 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-                      => RestrictedStatement r ()-                      -> UpdateTarget r r-updateTargetAllColumn = liftTargetAllColumn . restriction---- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'.-updateTargetAllColumn' :: PersistableWidth r-                       => RestrictedStatement r (PlaceHolders p)-                       -> UpdateTarget (r, p) r-updateTargetAllColumn' = liftTargetAllColumn' . restriction'----- | SQL SET clause and WHERE clause 'StringSQL' string from 'UpdateTarget'-sqlFromUpdateTarget :: Config -> Table r -> UpdateTarget p r -> StringSQL-sqlFromUpdateTarget config tbl (UpdateTarget q) = composeSets (asR tbl) <> composeWhere rs-  where ((_ph, asR), rs) = Assign.extract (q (Projection.unsafeFromTable tbl)) config--instance TableDerivable r => Show (UpdateTarget p r) where-  show = showStringSQL . sqlFromUpdateTarget defaultConfig derivedTable----- | InsertTarget type with place-holder parameter 'p' and projection record type 'r'.-newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p))---- | Finalize 'Register' monad and generate 'InsertTarget'.-insertTarget :: Register r ()-             -> InsertTarget () r-insertTarget =  InsertTarget . (>> return unitPlaceHolder)---- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'.-insertTarget' :: Register r (PlaceHolders p)-              -> InsertTarget p r-insertTarget' = InsertTarget---- | parametalized 'Register' monad from 'Pi'-piRegister :: PersistableWidth r-           => Pi r r'-           -> Register r (PlaceHolders r')-piRegister pi' = do-  let (ph', ma) = pwPlaceholder (Pi.width' pi') (\ph -> pi' <-# ph)-  () <- ma-  return ph'--sqlChunkFromInsertTarget' :: Config-                          -> Int-                          -> Table r-                          -> InsertTarget p r-                          -> StringSQL-sqlChunkFromInsertTarget' config sz tbl (InsertTarget q) =-    INSERT <> INTO <> stringSQL (Table.name tbl) <> composeChunkValuesWithColumns sz (asR tbl)-  where-    (_ph, asR) = Register.extract q config---- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget'-sqlChunkFromInsertTarget :: Config-                         -> Table r-                         -> InsertTarget p r-                         -> (StringSQL, Int)-sqlChunkFromInsertTarget config tbl it =-    (sqlChunkFromInsertTarget' config n tbl it, n)-  where-    th = chunksInsertSize config-    n  = (th + w - 1) `quot` w-    w  = Table.width tbl---- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget'-sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL-sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1

@@ -1,96 +0,0 @@--- |--- Module      : Database.Relational.Query.Internal.BaseSQL--- Copyright   : 2013-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module provides base structure of SQL syntax tree.-module Database.Relational.Query.Internal.BaseSQL (-  Duplication (..), showsDuplication,-  Order (..), Nulls (..), OrderColumn, OrderingTerm, composeOrderBy,-  AssignColumn, AssignTerm, Assignment, composeSets,-  composeChunkValues, composeChunkValuesWithColumns,-  ) where--import Data.Monoid (Monoid (..), (<>))--import Language.SQL.Keyword (Keyword(..), (|*|), (.=.))-import qualified Language.SQL.Keyword as SQL--import Database.Relational.Query.Internal.SQL-  (StringSQL, rowConsStringSQL)----- | Result record duplication attribute-data Duplication = All | Distinct  deriving Show---- | Compose duplication attribute string.-showsDuplication :: Duplication -> StringSQL-showsDuplication =  dup  where-  dup All      = ALL-  dup Distinct = DISTINCT----- | Order direction. Ascendant or Descendant.-data Order = Asc | Desc  deriving Show---- | Order of null.-data Nulls =  NullsFirst | NullsLast deriving Show---- | Type for order-by column-type OrderColumn = StringSQL---- | Type for order-by term-type OrderingTerm = ((Order, Maybe Nulls), OrderColumn)---- | Compose ORDER BY clause from OrderingTerms-composeOrderBy :: [OrderingTerm] -> StringSQL-composeOrderBy =  d where-  d []       = mempty-  d ts@(_:_) = ORDER <> BY <> SQL.fold (|*|) (map showsOt ts)-  showsOt ((o, mn), e) = e <> order o <> maybe mempty ((NULLS <>) . nulls) mn-  order Asc  = ASC-  order Desc = DESC-  nulls NullsFirst = FIRST-  nulls NullsLast  = LAST---- | Column SQL String of assignment-type AssignColumn = StringSQL---- | Value SQL String of assignment-type AssignTerm   = StringSQL---- | Assignment pair-type Assignment = (AssignColumn, AssignTerm)---- | Compose SET clause from ['Assignment'].-composeSets :: [Assignment] -> StringSQL-composeSets as = assigns  where-  assignList = foldr (\ (col, term) r ->-                       (col .=. term) : r)-               [] as-  assigns | null assignList = error "Update assignment list is null!"-          | otherwise       = SET <> SQL.fold (|*|) assignList---- | Compose VALUES clause from value expression list.-composeChunkValues :: Int         -- ^ record count per chunk-                   -> [StringSQL] -- ^ value expression list-                   -> Keyword-composeChunkValues n0 vs =-    VALUES <> cvs-  where-    n | n0 >= 1    =  n0-      | otherwise  =  error $ "Invalid record count value: " ++ show n0-    cvs = SQL.fold (|*|) . replicate n $ rowConsStringSQL vs---- | Compose VALUES clause from value expression list.-composeChunkValuesWithColumns :: Int          -- ^ record count per chunk-                              -> [Assignment] -- ^-                              -> StringSQL-composeChunkValuesWithColumns sz as =-    rowConsStringSQL cs <> composeChunkValues sz vs-  where-    (cs, vs) = unzip as

@@ -1,74 +0,0 @@--- |--- Module      : Database.Relational.Query.Internal.Config--- Copyright   : 2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines configuration datatype used in query products.-module Database.Relational.Query.Internal.Config (-  NameConfig (..),-  ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..),-  Config ( productUnitSupport-         , chunksInsertSize-         , schemaNameMode-         , normalizedTableName-         , verboseAsCompilerWarning-         , identifierQuotation-         , nameConfig),-  defaultConfig,-  ) where--import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName)-import qualified Database.Record.TH as RecordTH----- | 'NameConfig' type to customize names of expanded templates.-data NameConfig =-  NameConfig-  { recordConfig       ::  RecordTH.NameConfig-  , relationVarName    ::  String -> String -> VarName-  }--instance Show NameConfig where-  show = const "<NameConfig>"---- | Unit of product is supported or not.-data ProductUnitSupport = PUSupported | PUNotSupported  deriving Show---- | Schema name qualify mode in SQL string.-data SchemaNameMode-  = SchemaQualified     -- ^ Schema qualified table name in SQL string-  | SchemaNotQualified  -- ^ Not qualified table name in SQL string-  deriving (Eq, Show)---- | Configuration for quotation of identifiers of SQL.-data IdentifierQuotation = NoQuotation | Quotation Char deriving Show---- | Configuration type.-data Config =-  Config-  { productUnitSupport        ::  !ProductUnitSupport-  , chunksInsertSize          ::  !Int-  , schemaNameMode            ::  !SchemaNameMode-  , normalizedTableName       ::  !Bool-  , verboseAsCompilerWarning  ::  !Bool-  , identifierQuotation       ::  !IdentifierQuotation-  , nameConfig                ::  !NameConfig-  } deriving Show---- | Default configuration.-defaultConfig :: Config-defaultConfig =-  Config { productUnitSupport        =  PUSupported-         , chunksInsertSize          =  256-         , schemaNameMode            =  SchemaQualified-         , normalizedTableName       =  True-         , verboseAsCompilerWarning  =  False-         , identifierQuotation       =  NoQuotation-         , nameConfig                =  NameConfig { recordConfig     =  RecordTH.defaultNameConfig-                                                   , relationVarName  =  const varCamelcaseName-                                                   }-         }

@@ -1,39 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}---- |--- Module      : Database.Relational.Query.Internal.ContextType--- Copyright   : 2013-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines query context tag types.-module Database.Relational.Query.Internal.ContextType (-  Flat, Aggregated, Exists, OverWindow,--  Set, SetList, Power,-  ) 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 window function building-data OverWindow----- | Type tag for normal aggregatings set-data Set---- | Type tag for aggregatings GROUPING SETS-data SetList---- | Type tag for aggregatings power set-data Power

@@ -1,119 +0,0 @@--- |--- Module      : Database.Relational.Query.Internal.GroupingSQL--- Copyright   : 2013-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module provides grouping-sets structure of SQL syntax tree.-module Database.Relational.Query.Internal.GroupingSQL (-  AggregateColumnRef,-  AggregateBitKey (..), AggregateSet (..), AggregateElem (..),--  aggregateColumnRef, aggregateEmpty,-  aggregatePowerKey, aggregateGroupingSet,-  aggregateRollup, aggregateCube, aggregateSets,--  composeGroupBy, composePartitionBy,--  AggregateKey (..),--  aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey,-  ) where--import Data.Monoid (Monoid (..), (<>))--import Language.SQL.Keyword (Keyword(..), (|*|))-import qualified Language.SQL.Keyword as SQL--import Database.Relational.Query.Internal.SQL (StringSQL)----- | Type for group-by term-type AggregateColumnRef = StringSQL---- | 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---- | Typeful aggregate element.-newtype AggregateKey a = AggregateKey (a, AggregateElem)---- | 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 =  []--commaed :: [StringSQL] -> StringSQL-commaed =  SQL.fold (|*|)--pComma :: (a -> StringSQL) -> [a] -> StringSQL-pComma qshow =  SQL.paren . commaed . map qshow--showsAggregateBitKey :: AggregateBitKey -> StringSQL-showsAggregateBitKey (AggregateBitKey ts) = pComma id ts---- | Compose GROUP BY clause from AggregateElem list.-composeGroupBy :: [AggregateElem] -> StringSQL-composeGroupBy =  d where-  d []       = mempty-  d es@(_:_) = GROUP <> BY <> rec es-  keyList op ss = op <> pComma showsAggregateBitKey ss-  rec = commaed . map showsE-  showsGs (AggregateSet s) = SQL.paren $ rec s-  showsE (ColumnRef t)     = t-  showsE (Rollup ss)       = keyList ROLLUP ss-  showsE (Cube   ss)       = keyList CUBE   ss-  showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss---- | Compose PARTITION BY clause from AggregateColumnRef list.-composePartitionBy :: [AggregateColumnRef] -> StringSQL-composePartitionBy =  d where-  d []       = mempty-  d ts@(_:_) = PARTITION <> BY <> commaed ts---- | Extract typed projection from 'AggregateKey'.-aggregateKeyProjection :: AggregateKey a -> a-aggregateKeyProjection (AggregateKey (p, _c)) = p---- | Extract untyped term from 'AggregateKey'.-aggregateKeyElement :: AggregateKey a -> AggregateElem-aggregateKeyElement (AggregateKey (_p, c)) = c---- | Unsafely bind typed-projection and untyped-term into 'AggregateKey'.-unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a-unsafeAggregateKey = AggregateKey

@@ -1,53 +0,0 @@--- |--- Module      : Database.Relational.Query.Internal.Product--- Copyright   : 2013-2017 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 (-  -- * Interfaces to manipulate ProductTree type-  growProduct, restrictProduct,-  ) where--import Prelude hiding (and, product)-import Control.Applicative (pure)-import Data.Monoid ((<>), mempty)--import Database.Relational.Query.Internal.ContextType (Flat)-import Database.Relational.Query.Internal.Sub-  (NodeAttr (..), ProductTree (..), Node (..), Projection, Qualified, SubQuery,-   ProductTreeBuilder, ProductBuilder)----- | Push new tree into product right term.-growRight :: Maybe ProductBuilder           -- ^ Current tree-          -> (NodeAttr, ProductTreeBuilder) -- ^ New tree to push into right-          -> ProductBuilder                 -- ^ Result node-growRight = d  where-  d Nothing  (naR, q) = Node naR q-  d (Just l) (naR, q) = Node Just' $ Join l (Node naR q) mempty---- | Push new leaf node into product right term.-growProduct :: Maybe ProductBuilder           -- ^ Current tree-            -> (NodeAttr, Qualified SubQuery) -- ^ New leaf to push into right-            -> ProductBuilder                 -- ^ Result node-growProduct =  match  where-  match t (na, q) =  growRight t (na, Leaf q)---- | Add restriction into top product of product tree.-restrictProduct' :: ProductTreeBuilder           -- ^ Product to restrict-                 -> Projection Flat (Maybe Bool) -- ^ Restriction to add-                 -> ProductTreeBuilder           -- ^ Result product-restrictProduct' =  d  where-  d (Join lp rp rs) rs' = Join lp rp (rs <> pure rs')-  d leaf'@(Leaf _)         _   = leaf' -- or error on compile---- | Add restriction into top product of product tree node.-restrictProduct :: ProductBuilder               -- ^ Target node which has product to restrict-                -> Projection Flat (Maybe Bool) -- ^ Restriction to add-                -> ProductBuilder               -- ^ Result node-restrictProduct (Node a t) e = Node a (restrictProduct' t e)

@@ -1,52 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}---- |--- Module      : Database.Relational.Query.Internal.SQL--- Copyright   : 2014-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module provides SQL string wrap interfaces.-module Database.Relational.Query.Internal.SQL (-  StringSQL, stringSQL, showStringSQL,--  rowStringSQL, rowPlaceHolderStringSQL,--  rowConsStringSQL, listStringSQL,-  ) where--import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren)----- | String wrap type for SQL strings.-type StringSQL = Keyword---- | 'StringSQL' from 'String'.-stringSQL :: String -> StringSQL-stringSQL =  word---- | 'StringSQL' to 'String'.-showStringSQL :: StringSQL -> String-showStringSQL =  wordShow---- | Row String of SQL values.-rowStringSQL :: [StringSQL] -> StringSQL-rowStringSQL =  d  where-  d []  = error "Projection: no columns."-  d [c] = c-  d cs  = paren $ fold (|*|) cs---- | Place holder row String of SQL.-rowPlaceHolderStringSQL :: Int -> StringSQL-rowPlaceHolderStringSQL =  rowStringSQL . (`replicate` stringSQL "?")---- | List String of SQL.-rowConsStringSQL :: [StringSQL] -> StringSQL-rowConsStringSQL =  paren . fold (|*|)---- | List String of SQL.-listStringSQL :: [StringSQL] -> StringSQL-listStringSQL =  paren . fold (|*|)

@@ -1,204 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}---- |--- Module      : Database.Relational.Query.Internal.Sub--- Copyright   : 2015-2017 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.Internal.Sub-       ( SubQuery (..)-       , SetOp (..), BinOp (..), Qualifier (..)-       , Qualified (..), qualifier, unQualify, qualify--         -- * Product tree type-       , NodeAttr (..), ProductTree (..)-       , Node (..), nodeAttr, nodeTree-       , JoinProduct, QueryProductTree-       , ProductTreeBuilder, ProductBuilder--       , CaseClause (..), WhenClauses(..)-       , caseSearch, case'--       , UntypedProjection, untypedProjectionWidth, ProjectionUnit (..)-       , Projection, untypeProjection, typedProjection, projectionWidth-       , projectFromColumns, projectFromScalarSubQuery--         -- * Query restriction-       , QueryRestriction-       )  where--import Prelude hiding (and, product)-import Data.DList (DList)-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)--import Database.Relational.Query.Internal.Config (Config)-import Database.Relational.Query.Internal.ContextType (Flat, Aggregated)-import Database.Relational.Query.Internal.SQL (StringSQL)-import Database.Relational.Query.Internal.BaseSQL (Duplication (..), OrderingTerm)-import Database.Relational.Query.Internal.GroupingSQL (AggregateElem)-import Database.Relational.Query.Internal.UntypedTable (Untyped)----- | Set operators-data SetOp = Union | Except | Intersect  deriving Show---- | Set binary operators-newtype BinOp = BinOp (SetOp, Duplication) deriving Show---- | Sub-query type-data SubQuery = Table Untyped-              | Flat Config-                UntypedProjection Duplication JoinProduct (QueryRestriction Flat)-                [OrderingTerm]-              | Aggregated Config-                UntypedProjection Duplication JoinProduct (QueryRestriction Flat)-                [AggregateElem] (QueryRestriction Aggregated) [OrderingTerm]-              | Bin BinOp SubQuery SubQuery-              deriving Show---- | Qualifier type.-newtype Qualifier = Qualifier Int  deriving Show---- | Qualified query.-data Qualified a =-  Qualified Qualifier a-  deriving (Show, Functor, Foldable, Traversable)---- | Get qualifier-qualifier :: Qualified a -> Qualifier-qualifier (Qualified q _) = q---- | Unqualify.-unQualify :: Qualified a -> a-unQualify (Qualified _ a) = a---- | Add qualifier-qualify :: Qualifier -> a -> Qualified a-qualify = Qualified----- | node attribute for product.-data NodeAttr = Just' | Maybe deriving Show--type QS = Qualified SubQuery--type QueryRestrictionBuilder = DList (Projection Flat (Maybe Bool))---- | Product tree type. Product tree is constructed by left node and right node.-data ProductTree rs-  = Leaf QS-  | Join !(Node rs) !(Node rs) !rs-  deriving (Show, Functor)---- | Product node. node attribute and product tree.-data Node rs = Node !NodeAttr !(ProductTree rs)  deriving (Show, Functor)---- | Get node attribute.-nodeAttr :: Node rs -> NodeAttr-nodeAttr (Node a _) = a  where---- | Get tree from node.-nodeTree :: Node rs -> ProductTree rs-nodeTree (Node _ t) = t---- | Product tree with join restriction.-type QueryProductTree = ProductTree (QueryRestriction Flat)---- | Product tree with join restriction builder.-type ProductTreeBuilder = ProductTree QueryRestrictionBuilder---- | Product noe with join restriction builder.-type ProductBuilder = Node QueryRestrictionBuilder---- | Type for join product of query.-type JoinProduct = Maybe QueryProductTree---- | when clauses-data WhenClauses =-  WhenClauses [(UntypedProjection, UntypedProjection)] UntypedProjection-  deriving Show---- | case clause-data CaseClause-  = CaseSearch WhenClauses-  | CaseSimple UntypedProjection WhenClauses-  deriving Show---- | Projection structure unit with single column width-data ProjectionUnit-  = RawColumn StringSQL            -- ^ used in immediate value or unsafe operations-  | SubQueryRef (Qualified Int)    -- ^ normalized sub-query reference T<n> with Int index-  | Scalar SubQuery                -- ^ scalar sub-query-  | Case CaseClause Int            -- ^ <n>th column of case clause-  deriving Show---- | Untyped projection. Forgot record type.-type UntypedProjection = [ProjectionUnit]---- | Width of 'UntypedProjection'.-untypedProjectionWidth :: UntypedProjection -> Int-untypedProjectionWidth = length---- | Phantom typed projection. Projected into Haskell record type 't'.-newtype Projection c t =-  Projection-  { untypeProjection :: UntypedProjection {- ^ Discard projection value type -} }  deriving Show---- | Unsafely type projection value.-typedProjection :: UntypedProjection -> Projection c t-typedProjection =  Projection---- | Width of 'Projection'.-projectionWidth :: Projection c r -> Int-projectionWidth = length . untypeProjection---- | Unsafely generate 'Projection' from SQL string list.-projectFromColumns :: [StringSQL]    -- ^ SQL string list specifies columns-                   -> Projection c r -- ^ Result 'Projection'-projectFromColumns =  typedProjection . map RawColumn---- | Unsafely generate 'Projection' from scalar sub-query.-projectFromScalarSubQuery :: SubQuery -> Projection c t-projectFromScalarSubQuery = typedProjection . (:[]) . Scalar--whenClauses :: String                             -- ^ Error tag-            -> [(Projection c a, Projection c b)] -- ^ Each when clauses-            -> Projection c b                     -- ^ Else result projection-            -> WhenClauses                        -- ^ Result clause-whenClauses eTag ws0 e = d ws0-  where-    d []       = error $ eTag ++ ": Empty when clauses!"-    d ws@(_:_) =-      WhenClauses [ (untypeProjection p, untypeProjection r) | (p, r) <- ws ]-      $ untypeProjection e---- | Search case operator correnponding SQL search /CASE/.---   Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/-caseSearch :: [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses-           -> Projection c a                                -- ^ Else result projection-           -> Projection c a                                -- ^ Result projection-caseSearch ws e =-    typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ]-  where-    c = CaseSearch $ whenClauses "caseSearch" ws e---- | Simple case operator correnponding SQL simple /CASE/.---   Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/-case' :: Projection c a                     -- ^ Projection value to match-      -> [(Projection c a, Projection c b)] -- ^ Each when clauses-      -> Projection c b                     -- ^ Else result projection-      -> Projection c b                     -- ^ Result projection-case' v ws e =-    typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ]-  where-    c = CaseSimple (untypeProjection v) $ whenClauses "case'" ws e----- | Type for restriction of query.-type QueryRestriction c = [Projection c (Maybe Bool)]

@@ -1,44 +0,0 @@--- |--- Module      : Database.Relational.Query.Internal.UntypedTable--- Copyright   : 2013-2017 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines no-phantom table type which has table metadatas.-module Database.Relational.Query.Internal.UntypedTable (-  Untyped (Untyped), name', width', columns', (!),-  ) where--import Data.Array (Array, elems)-import qualified Data.Array as Array--import Database.Relational.Query.Internal.SQL (StringSQL)----- | Untyped typed table type-data Untyped = Untyped String Int (Array Int StringSQL)  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 StringSQL-columnArray (Untyped _ _ c) = c---- | Column name strings in SQL-columns' :: Untyped -> [StringSQL]-columns' =  elems . columnArray---- | Column name string in SQL specified by index-(!) :: Untyped-    -> Int       -- ^ Column index-    -> StringSQL -- ^ Column name String in SQL-t ! i = columnArray t Array.! i

@@ -1,103 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- |--- Module      : Database.Relational.Query.Monad.Aggregate--- Copyright   : 2013-2017 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,--  Window, over-  ) where--import Data.Functor.Identity (Identity (runIdentity))-import Data.Monoid ((<>))--import Language.SQL.Keyword (Keyword(..))-import qualified Language.SQL.Keyword as SQL--import Database.Relational.Query.Internal.BaseSQL (Duplication, OrderingTerm, composeOrderBy)-import Database.Relational.Query.Internal.GroupingSQL (AggregateColumnRef, AggregateElem, composePartitionBy)--import Database.Relational.Query.Context (Flat, Aggregated, OverWindow)-import Database.Relational.Query.Projection (Projection)-import qualified Database.Relational.Query.Projection as Projection-import Database.Relational.Query.Sub (SubQuery, QueryRestriction, JoinProduct, aggregatedSubQuery)-import qualified Database.Relational.Query.Sub as SubQuery-import Database.Relational.Query.Projectable (PlaceHolders, SqlProjectable)-import Database.Relational.Query.Monad.Class (MonadRestrict(..))-import Database.Relational.Query.Monad.Trans.Restricting-  (Restrictings, restrictings, extractRestrict)-import Database.Relational.Query.Monad.Trans.Aggregating-  (extractAggregateTerms, AggregatingSetT, PartitioningSet)-import Database.Relational.Query.Monad.Trans.Ordering-  (Orderings, extractOrderingTerms)-import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig)-import Database.Relational.Query.Monad.Type (QueryCore, extractCore, OrderedQuery)----- | Aggregated query monad type.-type QueryAggregate     = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore))---- | Aggregated query type. 'AggregatedQuery' p r == 'QueryAggregate' ('PlaceHolders' p, 'Projection' 'Aggregated' r).-type AggregatedQuery p r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) p r---- | Partition monad type for partition-by clause.-type Window           c = Orderings c (PartitioningSet c)---- | Restricted 'MonadRestrict' instance.-instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where-  restrict = restrictings . restrict--extract :: AggregatedQuery p r-        -> ConfigureQuery (((((((PlaceHolders p, Projection Aggregated r), [OrderingTerm]),-                               QueryRestriction Aggregated),-                              [AggregateElem]),-                             QueryRestriction Flat),-                            JoinProduct), Duplication)-extract =  extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms---- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation.-toSQL :: AggregatedQuery p 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 p r       -- ^ 'AggregatedQuery' to run-           -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation-toSubQuery q = do-  (((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q-  c <- askConfig-  return $ aggregatedSubQuery c (Projection.untype pj) da pd rs ag grs ot--extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef])-extractWindow =  runIdentity . extractAggregateTerms . extractOrderingTerms---- | Operator to make window function result projection using built 'Window' monad.-over :: SqlProjectable (Projection c)-     => Projection OverWindow a-     -> Window c ()-     -> Projection c a-wp `over` win =-  Projection.unsafeFromSqlTerms-  [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot)-  | c <- Projection.columns wp-  ]  where (((), ot), pt) = extractWindow win--infix 8 `over`

@@ -1,49 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- |--- Module      : Database.Relational.Query.Monad.Assign--- Copyright   : 2013-2017 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.Assign (-  -- * Monad to restrict target records with assignment.-  Assign, AssignStatement,-  -- updateStatement,-  extract,-  ) where--import Database.Relational.Query.Internal.BaseSQL (Assignment)-import Database.Relational.Query.Internal.Config (Config)--import Database.Relational.Query.Sub (QueryRestriction)-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 Assign r = Assignings r Restrict---- | AssignStatement type synonym.---   Specifying assignments and restrictions like update statement.---   Projection record type must be---   the same as 'Target' type parameter 'r'.-type AssignStatement r a = Projection Flat r -> Assign r a---- -- | 'return' of 'Update'--- updateStatement :: a -> Assignings r (Restrictings Identity) a--- updateStatement =  assignings . restrictings . Identity---- | Run 'Assign'.-extract :: Assign r a -> Config -> ((a, Table r -> [Assignment]), QueryRestriction Flat)-extract =  Restrict.extract . extractAssignments