relational-query 0.7.1.0 → 0.8.0.0

raw patch · 28 files changed

+400/−402 lines, 28 filesdep ~persistable-recordPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: persistable-record

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• relational-query.cabal +2/−3
• src/Database/Relational/Query.hs +2/−4
• src/Database/Relational/Query/Arrow.hs +1/−11
• src/Database/Relational/Query/Component.hs +29/−3
• src/Database/Relational/Query/Derives.hs +2/−1
• src/Database/Relational/Query/Effect.hs +42/−24
• src/Database/Relational/Query/Expr.hs +0/−55
• src/Database/Relational/Query/Expr/Unsafe.hs +0/−32
• src/Database/Relational/Query/Internal/Product.hs +13/−51
• src/Database/Relational/Query/Internal/Sub.hs +25/−6
• src/Database/Relational/Query/Monad/Aggregate.hs +2/−2
• src/Database/Relational/Query/Monad/Class.hs +2/−19
• src/Database/Relational/Query/Monad/Register.hs +29/−0
• src/Database/Relational/Query/Monad/Simple.hs +2/−2
• src/Database/Relational/Query/Monad/Trans/Join.hs +7/−8
• src/Database/Relational/Query/Monad/Trans/JoinState.hs +1/−1
• src/Database/Relational/Query/Monad/Trans/Restricting.hs +5/−7
• src/Database/Relational/Query/Monad/Type.hs +1/−2
• src/Database/Relational/Query/Monad/Unique.hs +3/−3
• src/Database/Relational/Query/Projectable.hs +1/−28
• src/Database/Relational/Query/ProjectableExtended.hs +2/−26
• src/Database/Relational/Query/Projection.hs +15/−28
• src/Database/Relational/Query/Relation.hs +1/−3
• src/Database/Relational/Query/Sub.hs +27/−12
• src/Database/Relational/Query/TH.hs +132/−63
• src/Database/Relational/Query/Type.hs +38/−8
• test/sqlsEq.hs +9/−0

@@ -1,5 +1,12 @@ <!-- -*- Markdown -*- --> +## 0.8.0.0++- Drop unsafe Expr type.+- Drop redundant type synonyms around DELETE and UPDATE.+- Add Register monad to add build-able INSERT statement+- Configurable relation template names.+ ## 0.7.1.0  - Deprecate redundant type synonyms.

@@ -1,5 +1,5 @@ name:                relational-query-version:             0.7.1.0+version:             0.8.0.0 synopsis:            Typeful, Modular, Relational, algebraic query engine description:         This package contiains typeful relation structure and                      relational-algebraic query building DSL which can@@ -34,8 +34,6 @@                        Database.Relational.Query.Context                        Database.Relational.Query.Projectable                        Database.Relational.Query.ProjectableExtended-                       Database.Relational.Query.Expr-                       Database.Relational.Query.Expr.Unsafe                        Database.Relational.Query.Component                        Database.Relational.Query.Sub                        Database.Relational.Query.Projection@@ -53,6 +51,7 @@                        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

@@ -15,7 +15,6 @@   module Database.Relational.Query.Pi,   module Database.Relational.Query.Constraint,   module Database.Relational.Query.Context,-  module Database.Relational.Query.Expr,   module Database.Relational.Query.Component,   module Database.Relational.Query.Sub,   module Database.Relational.Query.Projection,@@ -50,9 +49,8 @@    derivedUniqueKey, -- derivedNotNullKey,    Primary, Unique, NotNull) import Database.Relational.Query.Context-import Database.Relational.Query.Expr hiding (fromJust, just) import Database.Relational.Query.Component-  (Config (..), defaultConfig, ProductUnitSupport (..), Order (..))+  (NameConfig (..), Config (..), defaultConfig, ProductUnitSupport (..), Order (..)) import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth) import Database.Relational.Query.Projection (Projection, list) import Database.Relational.Query.Projectable@@ -63,7 +61,7 @@    MonadAggregate, groupBy, groupBy',    MonadQuery, query', queryMaybe',    MonadPartition, partitionBy,-   distinct, all', on, onE, wheresE, havingE)+   distinct, all', on) import Database.Relational.Query.Monad.Trans.Aggregating   (key, key', set, bkey, rollup, cube, groupingSets) import Database.Relational.Query.Monad.Trans.Ordering (orderBy, asc, desc)

@@ -59,7 +59,6 @@   Orderings, Window, Assignings,    AssignStatement, RestrictedStatement,-  UpdateTargetContext, RestrictionContext,   ) where  import Control.Category (Category)@@ -76,8 +75,7 @@    groupBy', key, key', set, bkey, rollup, cube, groupingSets,    orderBy, asc, desc, partitionBy, over,    derivedUpdate', derivedUpdate, derivedDelete', derivedDelete,-   QuerySimple, QueryAggregate, QueryUnique, Window,-   UpdateTargetContext, RestrictionContext)+   QuerySimple, QueryAggregate, QueryUnique, Window) import qualified Database.Relational.Query as Monadic import Database.Relational.Query.Projection (ListProjection) import Database.Relational.Query.Component (AggregateKey)@@ -130,14 +128,6 @@  -- | Arrow type corresponding to 'Monadic.RestrictedStatement' type RestrictedStatement r a = QueryA Monadic.Restrict (Projection Flat r) a--{-# DEPRECATED UpdateTargetContext "Expand UpdateTargetContext p r into AssignStatement r (PlaceHolders p)." #-}--- | Arrow type corresponding to 'Monadic.UpdateTargetContext'-type UpdateTargetContext p r = Assignings r Restrict (Projection Flat r) (PlaceHolders p)--{-# DEPRECATED RestrictionContext "Expand RestrictionContext p r into RestrictedStatement r (PlaceHolders p)." #-}--- | Arrow type corresponding to 'Monadic.RestrictionContext'-type RestrictionContext p r = QueryA Monadic.Restrict (Projection Flat r) (PlaceHolders p)   -- | Same as 'Monadic.all''. Arrow version.

@@ -17,7 +17,12 @@          ColumnSQL, columnSQL, columnSQL', showsColumnSQL,           -- * Configuration type for query-         Config (productUnitSupport, chunksInsertSize, normalizedTableName, verboseAsCompilerWarning),+         NameConfig (..),+         Config ( productUnitSupport+                , chunksInsertSize+                , normalizedTableName+                , verboseAsCompilerWarning+                , nameConfig),          defaultConfig,          ProductUnitSupport (..), Duplication (..), @@ -42,7 +47,7 @@          composeOrderBy,           -- * Types for assignments-         AssignColumn, AssignTerm, Assignment, Assignments, composeSets,+         AssignColumn, AssignTerm, Assignment, Assignments, composeSets, composeValues,           -- * Compose window clause          composeOver,@@ -50,10 +55,12 @@  import Data.Monoid (Monoid (..), (<>)) -import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowConsStringSQL) import Language.SQL.Keyword (Keyword(..), (|*|), (.=.))  import qualified Language.SQL.Keyword as SQL+import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName)+import qualified Database.Record.TH as RecordTH   -- | Simple wrap type@@ -84,7 +91,16 @@ instance Show ColumnSQL where   show = stringFromColumnSQL +-- | '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>"+ -- | Configuration type. data Config =   Config@@ -92,6 +108,7 @@   , chunksInsertSize          ::  Int   , normalizedTableName       ::  Bool   , verboseAsCompilerWarning  ::  Bool+  , nameConfig                ::  NameConfig   } deriving Show  -- | Default configuration.@@ -101,6 +118,9 @@          , chunksInsertSize          =  256          , normalizedTableName       =  True          , verboseAsCompilerWarning  =  False+         , nameConfig                =  NameConfig { recordConfig     =  RecordTH.defaultNameConfig+                                                   , relationVarName  =  const varCamelcaseName+                                                   }          }  -- | Unit of product is supported or not.@@ -250,6 +270,12 @@                [] as   assigns | null assignList = error "Update assignment list is null!"           | otherwise       = SET <> commaed assignList++-- | Compose VALUES clause from 'Assignments'.+composeValues :: Assignments -> StringSQL+composeValues as = rowConsStringSQL [ showsColumnSQL c | c <- cs ] <> VALUES <>+                   rowConsStringSQL [ showsColumnSQL c | c <- vs ]  where+  (cs, vs) = unzip as   -- | Compose /OVER (PARTITION BY ... )/ clause.

@@ -37,8 +37,9 @@ 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) import Database.Relational.Query.Relation-  (Relation, derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique)+  (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) import Database.Relational.Query.Constraint    (Key, Primary, Unique, projectionKey, uniqueKey,     HasConstraintKey(constraintKey))

@@ -11,55 +11,57 @@ -- like update and delete. module Database.Relational.Query.Effect (   -- * Object to express simple restriction.-  Restriction, RestrictionContext, restriction, restriction',+  Restriction, restriction, restriction',    -- * Object to express update target columns and restriction.-  UpdateTarget, UpdateTargetContext, updateTarget, updateTarget',+  UpdateTarget, updateTarget, updateTarget',   liftTargetAllColumn, liftTargetAllColumn',   updateTargetAllColumn, updateTargetAllColumn', +  -- * Object to express insert terget.+  InsertTarget, insertTarget, insertTarget',+   -- * Generate SQL from restriction.   sqlWhereFromRestriction,-  sqlFromUpdateTarget+  sqlFromUpdateTarget,+  sqlFromInsertTarget   ) where  import Data.Monoid ((<>))-import Control.Monad (void)  import Database.Record (PersistableWidth) -import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL)-import Database.Relational.Query.Context (Flat)+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) import Database.Relational.Query.Pi (id') import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)-import Database.Relational.Query.Component (Config, defaultConfig, composeSets)+import qualified Database.Relational.Query.Table as Table+import Database.Relational.Query.Component (Config, defaultConfig, composeSets, composeValues) import Database.Relational.Query.Sub (composeWhere)-import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable-  (PlaceHolders, placeholder, unsafeAddPlaceHolders, (><), rightId)+  (PlaceHolders, placeholder, unitPlaceHolder, unsafeAddPlaceHolders, (><), rightId)  import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#))-import Database.Relational.Query.Monad.Restrict (Restrict, RestrictedStatement)+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 +import Language.SQL.Keyword (Keyword(..)) --- | Restriction type with place-holder parameter 'p' and projection record type 'r'.-newtype Restriction p r = Restriction (Projection Flat r -> Restrict ()) -{-# DEPRECATED RestrictionContext "Expand RestrictionContext p r into RestrictedStatement r (PlaceHolders p)." #-}--- | Not finalized 'Restrict' monad type.-type RestrictionContext p r = RestrictedStatement r (PlaceHolders p)+-- | 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+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 . (void .)+restriction' = Restriction  runRestriction :: Restriction p r                -> RestrictedStatement r (PlaceHolders p)@@ -75,22 +77,19 @@ 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 ()) -{-# DEPRECATED UpdateTargetContext "Expand UpdateTargetContext p r into AssignStatement r (PlaceHolders p)." #-}--- | Not finalized 'Target' monad type.-type UpdateTargetContext p r = AssignStatement r (PlaceHolders p)+-- | 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+updateTarget =  UpdateTarget . ((>> return unitPlaceHolder) .)  -- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'. updateTarget' :: AssignStatement r (PlaceHolders p)               -> UpdateTarget p r-updateTarget' qf = UpdateTarget $ void . qf+updateTarget' = UpdateTarget  _runUpdateTarget :: UpdateTarget p r                  -> AssignStatement r (PlaceHolders p)@@ -137,3 +136,22 @@  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++-- | SQL INSERT statement 'StringSQL' string from 'InsertTarget'+sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL+sqlFromInsertTarget config tbl (InsertTarget q) = INSERT <> INTO <> stringSQL (Table.name tbl) <> composeValues (asR tbl)+  where (_ph, asR) = Register.extract q config

@@ -1,55 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}---- |--- Module      : Database.Relational.Query.Expr--- Copyright   : 2013 Kei Hibino--- License     : BSD3------ Maintainer  : ex8k.hibino@gmail.com--- Stability   : experimental--- Portability : unknown------ This module defines phantom typed SQL expression object.--- Contains normal interfaces.-module Database.Relational.Query.Expr {-# DEPRECATED "Drop in next version." #-} (-  -- * Typed SQL Expression-  Expr,--  valueExpr,--  -- * Type conversion-  just, fromJust,--  exprAnd-  ) where--import Prelude hiding (and, or)--import Database.Relational.Query.Expr.Unsafe (Expr(Expr), unsafeStringSql)-import Database.Relational.Query.Pure (ShowConstantTermsSQL, showConstantTermsSQL')-import Database.Relational.Query.Internal.SQL (rowStringSQL)--import qualified Language.SQL.Keyword as SQL----- | Typed constant SQL expression from Haskell value.-valueExpr :: ShowConstantTermsSQL ft => ft -> Expr p ft-valueExpr =  Expr . rowStringSQL . showConstantTermsSQL'---- | Unsafely cast phantom type.-unsafeCastExpr :: Expr p a -> Expr p b-unsafeCastExpr =  Expr . unsafeStringSql---- | Convert phantom type into 'Maybe'.-just :: Expr p ft -> Expr p (Maybe ft)-just =  unsafeCastExpr---- | Allowed only for having or where 'Expr'.---   So NULL expression result will be possible.---   Behavior around boolean is strongly dependent on RDBMS impelemetations.-fromJust :: Expr p (Maybe ft) -> Expr p ft-fromJust =  unsafeCastExpr---- | AND operator for 'Expr'.-exprAnd :: Expr p Bool -> Expr p Bool -> Expr p Bool-exprAnd a b = Expr . SQL.paren $ SQL.and (unsafeStringSql a) (unsafeStringSql b)

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

@@ -10,33 +10,18 @@ -- This module defines product structure to compose SQL join. module Database.Relational.Query.Internal.Product (   -- * Product tree type-  NodeAttr (..), ProductTree (..),-  Node, node, nodeAttr, nodeTree,-  growRight, -- growLeft,-  growProduct, product, restrictProduct,+  node, nodeAttr, nodeTree,+  growProduct, restrictProduct,   ) where  import Prelude hiding (and, product)-import Database.Relational.Query.Context (Flat)-import Database.Relational.Query.Expr (exprAnd)-import qualified Database.Relational.Query.Expr as Expr+import Control.Applicative (pure, empty) import Data.Monoid ((<>))-import Data.Foldable (Foldable (foldMap)) +import Database.Relational.Query.Context (Flat)+import Database.Relational.Query.Internal.Sub (NodeAttr (..), ProductTree (..), Node (..), Projection) -type Expr = Expr.Expr Flat --- | node attribute for product.-data NodeAttr = Just' | Maybe deriving Show---- | Product tree type. Product tree is constructed by left node and right node.-data ProductTree q = Leaf q-                   | Join !(Node q) !(Node q) !(Maybe (Expr Bool))-                   deriving Show---- | Product node. node attribute and product tree.-data Node q = Node !NodeAttr !(ProductTree q)  deriving Show- -- | Get node attribute. nodeAttr :: Node q -> NodeAttr nodeAttr (Node a _) = a  where@@ -45,12 +30,6 @@ nodeTree :: Node q -> ProductTree q nodeTree (Node _ t) = t --- | Foldable instance of ProductTree-instance Foldable ProductTree where-  foldMap f = rec  where-    rec (Leaf q) = f q-    rec (Join (Node _ lp) (Node _ rp) _ ) = rec lp <> rec rp- -- | Make product node from node attribute and product tree. node :: NodeAttr      -- ^ Node attribute      -> ProductTree q -- ^ Product tree@@ -63,16 +42,7 @@           -> Node q                    -- ^ Result node growRight = d  where   d Nothing  (naR, q) = node naR q-  d (Just l) (naR, q) = node Just' $ Join l (node naR q) Nothing---- -- | Push new tree node into product left term.--- growLeft :: Node q         -- ^ New node to push into left---          -> NodeAttr       -- ^ Node attribute to replace rigth node attribute.---          -> Maybe (Node q) -- ^ Current tree---          -> Node q         -- ^ Result node--- growLeft =  d  where---   d q _naR Nothing  = q -- error is better?---   d q naR  (Just r) = node Just' $ Join q (node naR (nodeTree r)) Nothing+  d (Just l) (naR, q) = node Just' $ Join l (node naR q) empty  -- | Push new leaf node into product right term. growProduct :: Maybe (Node q) -- ^ Current tree@@ -81,24 +51,16 @@ growProduct =  match  where   match t (na, q) =  growRight t (na, Leaf q) --- | Just make product of two node.-product :: Node q            -- ^ Left node-        -> Node q            -- ^ Right node-        -> Maybe (Expr Bool) -- ^ Join restriction-        -> ProductTree q     -- ^ Result tree-product =  Join- -- | Add restriction into top product of product tree.-restrictProduct' :: ProductTree q -- ^ Product to restrict-                 -> Expr Bool     -- ^ Restriction to add-                 -> ProductTree q -- ^ Result product+restrictProduct' :: ProductTree q                -- ^ Product to restrict+                 -> Projection Flat (Maybe Bool) -- ^ Restriction to add+                 -> ProductTree q                -- ^ Result product restrictProduct' =  d  where-  d (Join lp rp Nothing)   rs' = Join lp rp (Just rs')-  d (Join lp rp (Just rs)) rs' = Join lp rp (Just $ rs `exprAnd` rs')+  d (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 :: Node q    -- ^ Target node which has product to restrict-                -> Expr Bool -- ^ Restriction to add-                -> Node q    -- ^ Result node+restrictProduct :: Node q                       -- ^ Target node which has product to restrict+                -> Projection Flat (Maybe Bool) -- ^ Restriction to add+                -> Node q                       -- ^ Result node restrictProduct (Node a t) e = node a (restrictProduct' t e)

@@ -10,29 +10,33 @@ -- This module defines sub-query structure used in query products. module Database.Relational.Query.Internal.Sub        ( SubQuery (..), UntypedProjection, ProjectionUnit (..)-       , JoinProduct, QueryProduct, QueryProductNode        , SetOp (..), BinOp (..), Qualifier (..), Qualified (..) +         -- * Product tree type+       , NodeAttr (..), ProductTree (..), Node (..)+       , JoinProduct, QueryProduct, QueryProductNode+        , Projection, untypeProjection, typedProjection           -- * Query restriction        , QueryRestriction        )  where +import Prelude hiding (and, product) import Data.Array (Array)+import Data.DList (DList)  import qualified Database.Relational.Query.Context as Context-import Database.Relational.Query.Expr (Expr)-import Database.Relational.Query.Internal.Product-  (ProductTree, Node) import Database.Relational.Query.Component   (ColumnSQL, Config, Duplication (..),    AggregateElem, OrderingTerms) import qualified Database.Relational.Query.Table as Table  +-- | Set operators data SetOp = Union | Except | Intersect  deriving Show +-- | Set binary operators newtype BinOp = BinOp (SetOp, Duplication) deriving Show  -- | Sub-query type@@ -65,6 +69,18 @@ -- | Untyped projection. Forgot record type. type UntypedProjection = [ProjectionUnit] ++-- | node attribute for product.+data NodeAttr = Just' | Maybe deriving Show++-- | Product tree type. Product tree is constructed by left node and right node.+data ProductTree q = Leaf q+                   | Join !(Node q) !(Node q) !(DList (Projection Context.Flat (Maybe Bool)))+                   deriving Show++-- | Product node. node attribute and product tree.+data Node q = Node !NodeAttr !(ProductTree q)  deriving Show+ -- | Product tree specialized by 'SubQuery'. type QueryProduct = ProductTree (Qualified SubQuery) -- | Product node specialized by 'SubQuery'.@@ -75,11 +91,14 @@   -- | Phantom typed projection. Projected into Haskell record type 't'.-newtype Projection c t = Projection { untypeProjection :: UntypedProjection }  deriving Show+newtype Projection c t =+  Projection+  { untypeProjection :: UntypedProjection {- ^ Discard projection value type -} }  deriving Show +-- | Unsafely type projection value. typedProjection :: UntypedProjection -> Projection c t typedProjection =  Projection   -- | Type for restriction of query.-type QueryRestriction c = [Expr c Bool]+type QueryRestriction c = [Projection c (Maybe Bool)]

@@ -34,8 +34,8 @@ import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Component   (AggregateColumnRef, Duplication, OrderingTerms, AggregateElem, composeOver, showsColumnSQL)-import Database.Relational.Query.Internal.Sub (QueryRestriction)-import Database.Relational.Query.Sub (SubQuery, aggregatedSubQuery, JoinProduct)+import Database.Relational.Query.Internal.Sub (SubQuery, QueryRestriction, JoinProduct)+import Database.Relational.Query.Sub (aggregatedSubQuery) import qualified Database.Relational.Query.Sub as SubQuery import Database.Relational.Query.Projectable (PlaceHolders, SqlProjectable) 

@@ -18,14 +18,12 @@          MonadQuery (..), MonadAggregate (..), MonadPartition (..),           all', distinct,-         onE, on, wheresE, wheres,-         havingE, having,+         on, wheres, having,        ) where  import Database.Relational.Query.Context (Flat, Aggregated)-import Database.Relational.Query.Expr (Expr) import Database.Relational.Query.Component (Duplication (..), AggregateKey)-import Database.Relational.Query.Projection (Projection, predicateProjectionFromExpr)+import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, Relation) @@ -80,28 +78,13 @@ distinct :: MonadQuery m => m () distinct =  setDuplication Distinct -{-# DEPRECATED onE "Drop in the next version." #-}--- | Add restriction to last join.-onE :: MonadQuery m => Expr Flat (Maybe Bool) -> m ()-onE =  restrictJoin . predicateProjectionFromExpr- -- | Add restriction to last join. Projection type version. on :: MonadQuery m => Projection Flat (Maybe Bool) -> m () on =  restrictJoin -{-# DEPRECATED wheresE "Drop in the next version." #-}--- | Add restriction to this query. Expr type version.-wheresE :: MonadRestrict Flat m => Expr Flat (Maybe Bool) -> m ()-wheresE =  restrict . predicateProjectionFromExpr- -- | Add restriction to this not aggregated query. wheres :: MonadRestrict Flat m => Projection Flat (Maybe Bool) -> m () wheres =  restrict--{-# DEPRECATED havingE "Drop in the next version." #-}--- | Add restriction to this aggregated query. Expr type version.-havingE :: MonadRestrict Aggregated m => Expr Aggregated (Maybe Bool) -> m ()-havingE =  restrict . predicateProjectionFromExpr  -- | Add restriction to this aggregated query. Aggregated Projection type version. having :: MonadRestrict Aggregated m => Projection Aggregated (Maybe Bool) -> m ()

@@ -0,0 +1,29 @@+-- |+-- Module      : Database.Relational.Query.Monad.Register+-- Copyright   : 2015 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.Query.Monad.Register (+  -- * Monad to register target records.+  Register,++  extract,+  ) where++import Database.Relational.Query.Component (Config, Assignments)+import Database.Relational.Query.Table (Table)+import Database.Relational.Query.Monad.BaseType (ConfigureQuery, configureQuery)+import Database.Relational.Query.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 -> Assignments)+extract = configureQuery . extractAssignments

@@ -35,8 +35,8 @@ import Database.Relational.Query.Projectable (PlaceHolders)  import Database.Relational.Query.Component (Duplication, OrderingTerms)-import Database.Relational.Query.Internal.Sub (QueryRestriction)-import Database.Relational.Query.Sub (SubQuery, flatSubQuery, JoinProduct)+import Database.Relational.Query.Internal.Sub (SubQuery, QueryRestriction, JoinProduct)+import Database.Relational.Query.Sub (flatSubQuery) import qualified Database.Relational.Query.Sub as SubQuery  

@@ -36,13 +36,12 @@ import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Monad.Trans.JoinState   (JoinContext, primeJoinContext, updateProduct, joinProduct)-import Database.Relational.Query.Internal.Product (NodeAttr (Just', Maybe), restrictProduct, growProduct)-import Database.Relational.Query.Projection (Projection)+import Database.Relational.Query.Internal.Sub (NodeAttr (Just', Maybe), Projection)+import Database.Relational.Query.Internal.Product (restrictProduct, growProduct) import qualified Database.Relational.Query.Projection as Projection-import Database.Relational.Query.Expr (Expr, fromJust) import Database.Relational.Query.Component (Duplication (All))-import Database.Relational.Query.Sub (SubQuery, Qualified, JoinProduct)-import Database.Relational.Query.Projectable (PlaceHolders, unsafeAddPlaceHolders, expr)+import Database.Relational.Query.Internal.Sub (SubQuery, Qualified, JoinProduct)+import Database.Relational.Query.Projectable (PlaceHolders, unsafeAddPlaceHolders)  import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, untypeRelation) import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadQuery (..))@@ -65,10 +64,10 @@ updateContext =  QueryJoin . modify  -- | Add last join product restriction.-updateJoinRestriction :: Monad m => Expr Flat (Maybe Bool) -> QueryJoin m ()+updateJoinRestriction :: Monad m => Projection Flat (Maybe Bool) -> QueryJoin m () updateJoinRestriction e = updateContext (updateProduct d)  where   d  Nothing  = error "on: Product is empty! Restrict target product is not found!"-  d (Just pt) = restrictProduct pt (fromJust e)+  d (Just pt) = restrictProduct pt e  instance MonadQualify q m => MonadQualify q (QueryJoin m) where   liftQualify = join' . liftQualify@@ -76,7 +75,7 @@ -- | Joinable query instance. instance MonadQuery (QueryJoin ConfigureQuery) where   setDuplication     = QueryJoin . lift . tell . Last . Just-  restrictJoin       = updateJoinRestriction . expr+  restrictJoin       = updateJoinRestriction   query'             = queryWithAttr Just'   queryMaybe' pr     = do     (ph, pj) <- queryWithAttr Maybe pr

@@ -17,7 +17,7 @@ import Prelude hiding (product)  import qualified Database.Relational.Query.Internal.Product as Product-import Database.Relational.Query.Sub (QueryProductNode, JoinProduct)+import Database.Relational.Query.Internal.Sub (QueryProductNode, JoinProduct)   -- | JoinContext type for QueryJoin.

@@ -26,9 +26,7 @@ import Control.Arrow (second) import Data.DList (DList, toList) -import Database.Relational.Query.Internal.Sub (QueryRestriction)-import Database.Relational.Query.Expr (Expr, fromJust)-import Database.Relational.Query.Projectable (expr)+import Database.Relational.Query.Internal.Sub (QueryRestriction, Projection)  import Database.Relational.Query.Monad.Class   (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..))@@ -38,7 +36,7 @@ --   Type 'c' is context tag of restriction building like --   Flat (where) or Aggregated (having). newtype Restrictings c m a =-  Restrictings (WriterT (DList (Expr c Bool)) m a)+  Restrictings (WriterT (DList (Projection c (Maybe Bool))) m a)   deriving (MonadTrans, Monad, Functor, Applicative)  -- | Lift to 'Restrictings'@@ -46,12 +44,12 @@ restrictings =  lift  -- | Add whole query restriction.-updateRestriction :: Monad m => Expr c (Maybe Bool) -> Restrictings c m ()-updateRestriction =  Restrictings . tell . pure . fromJust+updateRestriction :: Monad m => Projection c (Maybe Bool) -> Restrictings c m ()+updateRestriction =  Restrictings . tell . pure  -- | 'MonadRestrict' instance. instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where-  restrict = updateRestriction . expr+  restrict = updateRestriction  -- | Restricted 'MonadQualify' instance. instance MonadQualify q m => MonadQualify q (Restrictings c m) where

@@ -15,8 +15,7 @@        ) where  import Database.Relational.Query.Component (Duplication)-import Database.Relational.Query.Internal.Sub (QueryRestriction)-import Database.Relational.Query.Sub (JoinProduct)+import Database.Relational.Query.Internal.Sub (JoinProduct, QueryRestriction) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Projectable (PlaceHolders)

@@ -22,7 +22,7 @@ import Control.Applicative (Applicative)  import Database.Relational.Query.Context (Flat)-import Database.Relational.Query.Internal.Product (NodeAttr)+import Database.Relational.Query.Internal.Sub (NodeAttr) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection @@ -34,8 +34,8 @@ import Database.Relational.Query.Projectable (PlaceHolders)  import Database.Relational.Query.Component (Duplication)-import Database.Relational.Query.Internal.Sub (QueryRestriction)-import Database.Relational.Query.Sub (SubQuery, flatSubQuery, Qualified, JoinProduct)+import Database.Relational.Query.Internal.Sub (SubQuery, QueryRestriction, Qualified, JoinProduct)+import Database.Relational.Query.Sub (flatSubQuery)  -- | Unique query monad type. newtype QueryUnique a = QueryUnique (QueryCore a)

@@ -13,9 +13,6 @@ -- -- This module defines operators on various polymorphic projections. module Database.Relational.Query.Projectable (-  -- * Conversion between individual Projections-  expr,-   -- * Projectable from SQL strings   SqlProjectable (unsafeProjectSqlTerms'), unsafeProjectSql',   unsafeProjectSqlTerms, unsafeProjectSql,@@ -80,11 +77,8 @@   (PersistableWidth, PersistableRecordWidth, derivedWidth,    HasColumnConstraint, NotNull) -import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowStringSQL)+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow)-import Database.Relational.Query.Expr (Expr)-import qualified Database.Relational.Query.Expr as Expr-import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr  import Database.Relational.Query.Pure   (ShowConstantTermsSQL, showConstantTermsSQL', ProductConstructor (..))@@ -96,12 +90,6 @@ import qualified Database.Relational.Query.Projection as Projection  -{-# DEPRECATED expr "Drop in the next version." #-}--- | Project from Projection type into expression type.-expr :: Projection p a -> Expr p a-expr =  UnsafeExpr.Expr . Projection.unsafeStringSql-- -- | Interface to project SQL terms unsafely. class SqlProjectable p where   -- | Unsafely project from SQL expression terms.@@ -126,15 +114,9 @@ instance SqlProjectable (Projection OverWindow) where   unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms --- | Unsafely make 'Expr' from SQL terms.-instance SqlProjectable (Expr p) where-  unsafeProjectSqlTerms' = UnsafeExpr.Expr . rowStringSQL- class SqlProjectable p => OperatorProjectable p instance OperatorProjectable (Projection Flat) instance OperatorProjectable (Projection Aggregated)-instance OperatorProjectable (Expr Flat)-instance OperatorProjectable (Expr Aggregated)  -- | Unsafely Project single SQL term. unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t@@ -178,10 +160,6 @@               -> String -- ^ Result SQL expression string. unsafeShowSql =  showStringSQL . unsafeShowSql' --- | Unsafely get SQL term from 'Expr'.-instance ProjectableShowSql (Expr p) where-  unsafeShowSql' = UnsafeExpr.unsafeStringSql- -- | Unsafely get SQL term from 'Proejction'. instance ProjectableShowSql (Projection c) where   unsafeShowSql' = Projection.unsafeStringSql@@ -547,11 +525,6 @@ instance ProjectableMaybe (Projection c) where   just         = Projection.just   flattenMaybe = Projection.flattenMaybe---- | Control phantom 'Maybe' type in SQL expression type 'Expr'.-instance ProjectableMaybe (Expr p) where-  just         = Expr.just-  flattenMaybe = Expr.fromJust  -- | Zipping except for identity element laws. class ProjectableApplicative p => ProjectableIdZip p where

@@ -22,8 +22,6 @@   -- * Get narrower projections   (!), (?!), (?!?), (!??), -  (.!), (.?),-   -- * Aggregate functions   unsafeAggregateOp,   count,@@ -42,11 +40,10 @@ import qualified Language.SQL.Keyword as SQL  import Database.Relational.Query.Context (Flat, Aggregated, OverWindow)-import Database.Relational.Query.Expr (Expr, fromJust) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable-  (expr, PlaceHolders, unsafeUniOp,+  (PlaceHolders, unsafeUniOp,    ProjectableMaybe (flattenMaybe), ProjectableIdZip (leftId, rightId),    SqlProjectable) import Database.Relational.Query.Pi (Pi)@@ -131,10 +128,6 @@ instance Projectable Projection Projection where   project = id --- | Project from 'Projection' into 'Expr' 'Projection'.-instance Projectable Projection Expr where-  project = expr- projectPi :: Projectable Projection p1 => Projection c a -> Pi a b -> p1 c b projectPi p = project . Projection.pi p @@ -170,24 +163,7 @@       -> p c (Maybe b)   -- ^ Narrower projected object. 'Maybe' phantom type result (?!?) =  projectPiMaybe' -{-# DEPRECATED (.!) "Drop in the next version." #-}--- | Get narrower projected expression along with projectino path---   and strip 'Maybe' phantom type off.-(.!) :: Projection c (Maybe a) -- ^ Source projection type 'p'. 'Maybe' phantom type-     -> Pi a b      -- ^ Projection path-     -> Expr c b    -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off-(.!) p = fromJust . projectPiMaybe p -{-# DEPRECATED (.?) "Drop in the next version." #-}--- | Get narrower projected expression along with projectino path---   and strip 'Maybe' phantom type off.---   Projection path leaf is 'Maybe' case.-(.?) :: Projection c (Maybe a)    -- ^ Source projection type 'p'. 'Maybe' phantom type-     -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf-     -> Expr c b       -- ^ Narrower projected expression. 'Maybe' phantom type is stripped off-(.?) p = fromJust . projectPiMaybe' p-- -- | Interface to compose phantom 'Maybe' nested type. class ProjectableFlattenMaybe a b where   flatten :: ProjectableMaybe p => p a -> p b@@ -250,5 +226,5 @@ --       => p a -> p b -> p c -- (>?<) =  generalizedZip' -infixl 8 !, ?!, ?!?, !??, .!, .?+infixl 8 !, ?!, ?!?, !?? -- infixl 1 >?<

@@ -22,7 +22,6 @@   unsafeFromQualifiedSubQuery,   unsafeFromScalarSubQuery,   unsafeFromTable,-  predicateProjectionFromExpr,    unsafeStringSql, @@ -48,7 +47,7 @@ import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint) import qualified Database.Record.KeyConstraint as KeyConstraint -import Database.Relational.Query.Internal.SQL (StringSQL, rowStringSQL, listStringSQL)+import Database.Relational.Query.Internal.SQL (StringSQL, listStringSQL) import Database.Relational.Query.Internal.Sub   (SubQuery, UntypedProjection, Projection, untypeProjection, typedProjection, Qualified) import Database.Relational.Query.Context (Aggregated, Flat)@@ -56,35 +55,33 @@ import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Pure (ProductConstructor (..))-import Database.Relational.Query.Expr.Unsafe (Expr)-import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Relational.Query.Sub-  (widthOfUntypedProjection, columnsOfUntypedProjection, untypedProjectionFromColumns,-   untypedProjectionFromColumns, untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery)+  (widthOfUntypedProjection, projectionColumns,+   untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery,+   unsafeProjectionStringSql, unsafeProjectFromColumns) import qualified Database.Relational.Query.Sub as SubQuery  --- | Width of 'Projection'.-width :: Projection c r -> Int-width =  widthOfUntypedProjection . untypeProjection+-- | Unsafely get SQL term from 'Proejction'.+unsafeStringSql :: Projection c r -> StringSQL+unsafeStringSql = unsafeProjectionStringSql  -- | Get column SQL string list of projection. columns :: Projection c r -- ^ Source 'Projection'         -> [ColumnSQL]    -- ^ Result SQL string list-columns =  columnsOfUntypedProjection . untypeProjection+columns = projectionColumns +-- | Width of 'Projection'.+width :: Projection c r -> Int+width =  widthOfUntypedProjection . untypeProjection+ -- | Unsafely get untyped projection. untype :: Projection c r -> UntypedProjection untype =  untypeProjection  --- | Unsafely generate 'Projection' from SQL string list.-unsafeFromColumns :: [ColumnSQL]    -- ^ SQL string list specifies columns-                  -> Projection c r -- ^ Result 'Projection'-unsafeFromColumns =  typedProjection . untypedProjectionFromColumns- -- | Unsafely generate  'Projection' from qualified (joined) sub-query. unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection c t unsafeFromQualifiedSubQuery =  typedProjection . untypedProjectionFromJoinedSubQuery@@ -96,27 +93,17 @@ -- | Unsafely generate unqualified 'Projection' from 'Table'. unsafeFromTable :: Table r                 -> Projection c r-unsafeFromTable =  unsafeFromColumns . Table.columns--{-# DEPRECATED predicateProjectionFromExpr "Drop in the next version." #-}--- | Lift 'Expr' to 'Projection' to use as restrict predicate.-predicateProjectionFromExpr :: Expr c (Maybe Bool) -> Projection c (Maybe Bool)-predicateProjectionFromExpr =-  typedProjection . untypedProjectionFromColumns . (:[]) .  columnSQL' . UnsafeExpr.unsafeStringSql---- | Unsafely get SQL term from 'Proejction'.-unsafeStringSql :: Projection c r -> StringSQL-unsafeStringSql =  rowStringSQL . map showsColumnSQL . columns+unsafeFromTable =  unsafeProjectFromColumns . Table.columns  -- | Unsafely generate 'Projection' from SQL expression strings. unsafeFromSqlTerms :: [StringSQL] -> Projection c t-unsafeFromSqlTerms =  unsafeFromColumns . map columnSQL'+unsafeFromSqlTerms =  unsafeProjectFromColumns . map columnSQL'   -- | Unsafely trace projection path. unsafeProject :: Projection c a' -> Pi a b -> Projection c b' unsafeProject p pi' =-  unsafeFromColumns+  unsafeProjectFromColumns   . (`UnsafePi.pi` pi')   . columns $ p 

@@ -13,8 +13,6 @@ -- to compose complex query. module Database.Relational.Query.Relation (   -- * Relation type-  Relation,-   table, derivedRelation, tableOf,   relation, relation',   aggregateRelation, aggregateRelation',@@ -59,7 +57,7 @@  import Database.Relational.Query.Component (Duplication (Distinct, All)) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)-import Database.Relational.Query.Internal.Product (NodeAttr(Just', Maybe))+import Database.Relational.Query.Internal.Sub (NodeAttr(Just', Maybe)) import Database.Relational.Query.Sub (SubQuery) import qualified Database.Relational.Query.Sub as SubQuery 

@@ -24,12 +24,13 @@   -- * Sub-query columns   column, -  -- * Untyped projection+  -- * Projection   ProjectionUnit, UntypedProjection,    untypedProjectionFromColumns, untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery,   widthOfUntypedProjection, columnsOfUntypedProjection, +  projectionColumns, unsafeProjectionStringSql, unsafeProjectFromColumns,    -- * Product of sub-queries   QueryProduct, QueryProductNode, JoinProduct,@@ -38,21 +39,20 @@   composeWhere, composeHaving   ) where -import Data.Maybe (fromMaybe) import Data.Array (listArray) import qualified Data.Array as Array import Data.Monoid (mempty, (<>), mconcat)+import Data.DList (toList)  import qualified Database.Relational.Query.Context as Context-import Database.Relational.Query.Expr (valueExpr, exprAnd)-import Database.Relational.Query.Expr.Unsafe (unsafeStringSql)-import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, rowStringSQL, showStringSQL) import Database.Relational.Query.Internal.Product-  (NodeAttr(Just', Maybe), ProductTree (Leaf, Join),-   nodeAttr, nodeTree)+  (nodeAttr, nodeTree) import Database.Relational.Query.Internal.Sub-  (SubQuery (..), UntypedProjection, ProjectionUnit (..),+  (SubQuery (..), Projection, untypeProjection, typedProjection,+   UntypedProjection, ProjectionUnit (..),    JoinProduct, QueryProduct, QueryProductNode,+   NodeAttr (Just', Maybe), ProductTree (Leaf, Join),    SetOp (..), BinOp (..), Qualifier (..), Qualified (..),    QueryRestriction) import Database.Relational.Query.Component@@ -62,6 +62,7 @@    AggregateElem, composeGroupBy, OrderingTerms, composeOrderBy) import Database.Relational.Query.Table (Table, (!)) import qualified Database.Relational.Query.Table as Table+import Database.Relational.Query.Pure (showConstantTermsSQL')  import Language.SQL.Keyword (Keyword(..), (|*|)) import qualified Language.SQL.Keyword as SQL@@ -309,7 +310,21 @@ columnsOfUntypedProjection p = map (columnOfUntypedProjection p) . take w $ [0 .. ]   where w = widthOfUntypedProjection p +-- | Get column SQL string list of projection.+projectionColumns :: Projection c r -- ^ Source 'Projection'+                  -> [ColumnSQL]    -- ^ Result SQL string list+projectionColumns =  columnsOfUntypedProjection . untypeProjection +-- | Unsafely get SQL term from 'Proejction'.+unsafeProjectionStringSql :: Projection c r -> StringSQL+unsafeProjectionStringSql =  rowStringSQL . map showsColumnSQL . projectionColumns++-- | Unsafely generate 'Projection' from SQL string list.+unsafeProjectFromColumns :: [ColumnSQL]    -- ^ SQL string list specifies columns+                         -> Projection c r -- ^ Result 'Projection'+unsafeProjectFromColumns =  typedProjection . untypedProjectionFromColumns++ -- | Show product tree of query into SQL. StringSQL result. showsQueryProduct :: QueryProduct -> StringSQL showsQueryProduct =  rec  where@@ -326,8 +341,8 @@     [urec left',      joinType (nodeAttr left') (nodeAttr right'), JOIN,      urec right',-     ON,-     unsafeStringSql . fromMaybe (valueExpr True) {- or error on compile -}  $ rs]+     ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ]+    where ps = [ unsafeProjectionStringSql p | p <- toList rs ]  -- | Shows join product of query. showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL@@ -340,8 +355,8 @@ -- | Compose SQL String from 'QueryRestriction'. composeRestrict :: Keyword -> QueryRestriction c -> StringSQL composeRestrict k = d  where-  d    []    =  mempty-  d e@(_:_)  =  k <> unsafeStringSql (foldr1 exprAnd e)+  d     []    =  mempty+  d ps@(_:_)  =  k <> foldr1 SQL.and [ unsafeProjectionStringSql p | p <- ps ]  -- | Compose WHERE clause from 'QueryRestriction'. composeWhere :: QueryRestriction Context.Flat -> StringSQL

@@ -19,6 +19,7 @@ -- so mapping between list of untyped SQL type and Haskell record type will be done too. module Database.Relational.Query.TH (   -- * All templates about table+  defineTable,   defineTableDefault,    -- * Inlining typed 'Query'@@ -26,12 +27,15 @@   inlineQuery,    -- * Column projections and basic 'Relation' for Haskell record+  defineTableTypesAndRecord,   defineTableTypesAndRecordDefault,    -- * Constraint key templates   defineHasPrimaryKeyInstance,+  defineHasPrimaryKeyInstanceWithConfig,   defineHasPrimaryKeyInstanceDefault,   defineHasNotNullKeyInstance,+  defineHasNotNullKeyInstanceWithConfig,   defineHasNotNullKeyInstanceDefault,   defineScalarDegree, @@ -39,7 +43,7 @@   defineColumns, defineColumnsDefault,    -- * Table metadata type and basic 'Relation'-  defineTableTypes, defineTableTypesDefault,+  defineTableTypes, defineTableTypesWithConfig, defineTableTypesDefault,    -- * Basic SQL templates generate rules   definePrimaryQuery,@@ -48,6 +52,7 @@   -- * Var expression templates   derivationExpDefault,   tableVarExpDefault,+  relationVarExp,   relationVarExpDefault,    -- * Derived SQL templates from table definitions@@ -74,13 +79,13 @@ import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)  import Database.Record.TH-  (recordTypeNameDefault, recordTypeDefault, columnOffsetsVarNameDefault,-   defineRecordTypeDefault,-   defineHasColumnConstraintInstance)+  (columnOffsetsVarNameDefault, recordTypeName, recordType,+   defineRecordTypeWithConfig, defineHasColumnConstraintInstance) import qualified Database.Record.TH as Record  import Database.Relational.Query-  (Table, Pi, id', Relation, Config (normalizedTableName), ProductConstructor (..),+  (Table, Pi, id', Relation, ProductConstructor (..),+   NameConfig (..), Config (normalizedTableName, nameConfig), defaultConfig,    relationalQuerySQL, Query, relationalQuery, KeyUpdate,    Insert, derivedInsert, InsertQuery, derivedInsertQuery,    HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate)@@ -119,12 +124,24 @@   return $ kc ++ ck  -- | Rule template to infer primary key.-defineHasPrimaryKeyInstanceDefault :: String  -- ^ Table name+defineHasPrimaryKeyInstanceWithConfig :: Config  -- ^ configuration parameters+                                      -> String  -- ^ Schema name+                                      -> String  -- ^ Table name+                                      -> TypeQ   -- ^ Column type+                                      -> [Int]   -- ^ Primary key index+                                      -> Q [Dec] -- ^ Declarations of primary constraint key+defineHasPrimaryKeyInstanceWithConfig config scm =+  defineHasPrimaryKeyInstance . recordType (recordConfig $ nameConfig config) scm++{-# DEPRECATED defineHasPrimaryKeyInstanceDefault "Use ' defineHasPrimaryKeyInstanceWithConfig defaultConfig ' instead of this." #-}+-- | Rule template to infer primary key.+defineHasPrimaryKeyInstanceDefault :: String  -- ^ Schema name+                                   -> String  -- ^ Table name                                    -> TypeQ   -- ^ Column type                                    -> [Int]   -- ^ Primary key index                                    -> Q [Dec] -- ^ Declarations of primary constraint key defineHasPrimaryKeyInstanceDefault =-  defineHasPrimaryKeyInstance . recordTypeDefault+  defineHasPrimaryKeyInstanceWithConfig defaultConfig  -- | Rule template to infer not-null key. defineHasNotNullKeyInstance :: TypeQ   -- ^ Record type@@ -134,11 +151,22 @@   defineHasColumnConstraintInstance [t| NotNull |]  -- | Rule template to infer not-null key.-defineHasNotNullKeyInstanceDefault :: String  -- ^ Table name+defineHasNotNullKeyInstanceWithConfig :: Config  -- ^ configuration parameters+                                      -> String  -- ^ Schema name+                                      -> String  -- ^ Table name+                                      -> Int     -- ^ NotNull key index+                                      -> Q [Dec] -- ^ Declaration of not-null constraint key+defineHasNotNullKeyInstanceWithConfig config scm =+  defineHasNotNullKeyInstance . recordType (recordConfig $ nameConfig config) scm++{-# DEPRECATED defineHasNotNullKeyInstanceDefault "Use ' defineHasNotNullKeyInstanceWithConfig defaultConfig ' instead of this." #-}+-- | Rule template to infer not-null key.+defineHasNotNullKeyInstanceDefault :: String  -- ^ Schema name+                                   -> String  -- ^ Table name                                    -> Int     -- ^ NotNull key index                                    -> Q [Dec] -- ^ Declaration of not-null constraint key defineHasNotNullKeyInstanceDefault =-  defineHasNotNullKeyInstance . recordTypeDefault+  defineHasNotNullKeyInstanceWithConfig defaultConfig   -- | Column projection path 'Pi' template.@@ -189,8 +217,8 @@  -- | Rule template to infer table derivations. defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]-defineTableDerivableInstance recordType table columns =-  [d| instance TableDerivable $recordType where+defineTableDerivableInstance recordType' table columns =+  [d| instance TableDerivable $recordType' where         derivedTable = Table.table $(stringE table) $(listE $ map stringE columns)     |] @@ -201,18 +229,18 @@                        -> VarName -- ^ InsertQuery statement declaration variable name                        -> TypeQ   -- ^ Record type                        -> Q [Dec] -- ^ Table and Relation declaration-defineTableDerivations tableVar' relVar' insVar' insQVar' recordType = do+defineTableDerivations tableVar' relVar' insVar' insQVar' recordType' = do   let tableVar = varName tableVar'-  tableDs <- simpleValD tableVar [t| Table $recordType |]+  tableDs <- simpleValD tableVar [t| Table $recordType' |]              [| derivedTable |]   let relVar   = varName relVar'-  relDs   <- simpleValD relVar   [t| Relation () $recordType |]+  relDs   <- simpleValD relVar   [t| Relation () $recordType' |]              [| derivedRelation |]   let insVar   = varName insVar'-  insDs   <- simpleValD insVar   [t| Insert $recordType |]+  insDs   <- simpleValD insVar   [t| Insert $recordType' |]              [| derivedInsert id' |]   let insQVar  = varName insQVar'-  insQDs  <- simpleValD insQVar  [t| forall p . Relation p $recordType -> InsertQuery p |]+  insQDs  <- simpleValD insQVar  [t| forall p . Relation p $recordType' -> InsertQuery p |]              [| derivedInsertQuery id' |]   return $ concat [tableDs, relDs, insDs, insQDs] @@ -225,9 +253,9 @@                  -> String   -- ^ Table name in SQL ex. FOO_SCHEMA.table0                  -> [String] -- ^ Column names                  -> Q [Dec]  -- ^ Table and Relation declaration-defineTableTypes tableVar' relVar' insVar' insQVar' recordType table columns = do-  iDs <- defineTableDerivableInstance recordType table columns-  dDs <- defineTableDerivations tableVar' relVar' insVar' insQVar' recordType+defineTableTypes tableVar' relVar' insVar' insQVar' recordType' table columns = do+  iDs <- defineTableDerivableInstance recordType' table columns+  dDs <- defineTableDerivations tableVar' relVar' insVar' insQVar' recordType'   return $ iDs ++ dDs  tableSQL :: Bool -> String -> String -> String@@ -255,13 +283,19 @@                    -> ExpQ   -- ^ Result var Exp tableVarExpDefault =  toVarExp . tableVarNameDefault -relationVarNameDefault :: String -> VarName-relationVarNameDefault =  varCamelcaseName+-- | Make 'Relation' variable expression template from table name using specified naming rule.+relationVarExp :: Config -- ^ Configuration which has  naming rules of templates+                         -> String -- ^ Schema name string+                         -> String -- ^ Table name string+                         -> ExpQ   -- ^ Result var Exp+relationVarExp config scm = toVarExp . relationVarName (nameConfig config) scm +{-# DEPRECATED relationVarExpDefault "Use ' relationVarExp defaultConfig ' instead of this." #-} -- | Make 'Relation' variable expression template from table name using default naming rule.-relationVarExpDefault :: String -- ^ Table name string-                      -> ExpQ -- ^ Result var Exp-relationVarExpDefault =  toVarExp . relationVarNameDefault+relationVarExpDefault :: String -- ^ Schema name string+                      -> String -- ^ Table name string+                      -> ExpQ   -- ^ Result var Exp+relationVarExpDefault = relationVarExp defaultConfig  -- | Make template for 'ProductConstructor' instance. defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]@@ -270,33 +304,58 @@         productConstructor = $(recData)     |] --- | Make template for record 'ProductConstructor' instance using default naming rule.-defineProductConstructorInstanceDefault :: String -> [TypeQ] -> Q [Dec]-defineProductConstructorInstanceDefault table colTypes = do-  let typeName = recordTypeNameDefault table+-- | Make template for record 'ProductConstructor' instance using specified naming rule.+defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec]+defineProductConstructorInstanceWithConfig config schema table colTypes = do+  let typeName = recordTypeName (recordConfig $ nameConfig config) schema table   defineProductConstructorInstance     (toTypeCon typeName)     (toDataCon typeName)     colTypes --- | Make templates about table and column metadatas using default naming rule.-defineTableTypesDefault :: Config                           -- ^ Configuration to generate query with-                        -> String                           -- ^ Schema name-                        -> String                           -- ^ Table name-                        -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type-                        -> Q [Dec]                          -- ^ Result declarations-defineTableTypesDefault config schema table columns = do+-- | Make templates about table and column metadatas using specified naming rule.+defineTableTypesWithConfig :: Config                           -- ^ Configuration to generate query with+                           -> String                           -- ^ Schema name+                           -> String                           -- ^ Table name+                           -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type+                           -> Q [Dec]                          -- ^ Result declarations+defineTableTypesWithConfig config schema table columns = do+  let nmconfig = nameConfig config+      recConfig = recordConfig nmconfig   tableDs <- defineTableTypes              (tableVarNameDefault table)-             (relationVarNameDefault table)+             (relationVarName nmconfig schema table)              (table `varNameWithPrefix` "insert")              (table `varNameWithPrefix` "insertQuery")-             (recordTypeDefault table)+             (recordType recConfig schema table)              (tableSQL (normalizedTableName config) schema table)              (map (fst . fst) columns)-  colsDs <- defineColumnsDefault (recordTypeNameDefault table) columns+  colsDs <- defineColumnsDefault (recordTypeName recConfig schema table) columns   return $ tableDs ++ colsDs +{-# DEPRECATED defineTableTypesDefault "Use defineTableTypesWithConfig instead of this." #-}+-- | Make templates about table and column metadatas using default naming rule.+defineTableTypesDefault :: Config                           -- ^ Configuration to generate query with+                        -> String                           -- ^ Schema name+                        -> String                           -- ^ Table name+                        -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type+                        -> Q [Dec]                          -- ^ Result declarations+defineTableTypesDefault = defineTableTypesWithConfig++-- | Make templates about table, column and haskell record using specified naming rule.+defineTableTypesAndRecord :: Config            -- ^ Configuration to generate query with+                          -> String            -- ^ Schema name+                          -> String            -- ^ Table name+                          -> [(String, TypeQ)] -- ^ Column names and types+                          -> [Name]            -- ^ Record derivings+                          -> Q [Dec]           -- ^ Result declarations+defineTableTypesAndRecord config schema table columns derives = do+  recD    <- defineRecordTypeWithConfig (recordConfig $ nameConfig config) schema table columns derives+  rconD   <- defineProductConstructorInstanceWithConfig config schema table [t | (_, t) <- columns]+  tableDs <- defineTableTypesWithConfig config schema table [(c, Nothing) | c <- columns ]+  return $ recD ++ rconD ++ tableDs++{-# DEPRECATED defineTableTypesAndRecordDefault "Use defineTableTypesAndRecord instead of this." #-} -- | Make templates about table, column and haskell record using default naming rule. defineTableTypesAndRecordDefault :: Config            -- ^ Configuration to generate query with                                  -> String            -- ^ Schema name@@ -304,11 +363,7 @@                                  -> [(String, TypeQ)] -- ^ Column names and types                                  -> [Name]            -- ^ Record derivings                                  -> Q [Dec]           -- ^ Result declarations-defineTableTypesAndRecordDefault config schema table columns derives = do-  recD    <- defineRecordTypeDefault table columns derives-  rconD   <- defineProductConstructorInstanceDefault table [t | (_, t) <- columns]-  tableDs <- defineTableTypesDefault config schema table [(c, Nothing) | c <- columns ]-  return $ recD ++ rconD ++ tableDs+defineTableTypesAndRecordDefault = defineTableTypesAndRecord  -- | Template of derived primary 'Query'. definePrimaryQuery :: VarName -- ^ Variable name of result declaration@@ -362,22 +417,44 @@     upd = table `varNameWithPrefix` "update"  -- | All templates about primary key.-defineWithPrimaryKeyDefault :: String  -- ^ Table name string-                            -> TypeQ   -- ^ Type of primary key-                            -> [Int]   -- ^ Indexes specifies primary key-                            -> Q [Dec] -- ^ Result declarations-defineWithPrimaryKeyDefault table keyType ixs = do-  instD <- defineHasPrimaryKeyInstanceDefault table keyType ixs-  let recType  = recordTypeDefault table+defineWithPrimaryKey :: Config+                     -> String  -- ^ Schema name+                     -> String  -- ^ Table name string+                     -> TypeQ   -- ^ Type of primary key+                     -> [Int]   -- ^ Indexes specifies primary key+                     -> Q [Dec] -- ^ Result declarations+defineWithPrimaryKey config schema table keyType ixs = do+  instD <- defineHasPrimaryKeyInstanceWithConfig config schema table keyType ixs+  let recType  = recordType (recordConfig $ nameConfig config) schema table       tableE   = tableVarExpDefault table-      relE     = relationVarExpDefault table+      relE     = relationVarExp config schema table   sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE   return $ instD ++ sqlsD  -- | All templates about not-null key.-defineWithNotNullKeyDefault :: String -> Int -> Q [Dec]-defineWithNotNullKeyDefault =  defineHasNotNullKeyInstanceDefault+defineWithNotNullKeyWithConfig :: Config -> String -> String -> Int -> Q [Dec]+defineWithNotNullKeyWithConfig = defineHasNotNullKeyInstanceWithConfig +-- | Generate all templtes about table using specified naming rule.+defineTable :: Config            -- ^ Configuration to generate query with+            -> String            -- ^ Schema name string of Database+            -> String            -- ^ Table name string of Database+            -> [(String, TypeQ)] -- ^ Column names and types+            -> [Name]            -- ^ derivings for Record type+            -> [Int]             -- ^ Primary key index+            -> Maybe Int         -- ^ Not null key index+            -> Q [Dec]           -- ^ Result declarations+defineTable config schema table columns derives primaryIxs mayNotNullIdx = do+  tblD  <- defineTableTypesAndRecord config schema table columns derives+  let pairT x y = appT (appT (tupleT 2) x) y+      keyType   = foldl1' pairT . map (snd . (columns !!)) $ primaryIxs+  primD <- case primaryIxs of+    []  -> return []+    ixs -> defineWithPrimaryKey config schema table keyType ixs+  nnD   <- maybeD (\i -> defineWithNotNullKeyWithConfig config schema table i) mayNotNullIdx+  return $ tblD ++ primD ++ nnD++{-# DEPRECATED defineTableDefault "Use defineTable instead of this." #-} -- | Generate all templtes about table using default naming rule. defineTableDefault :: Config            -- ^ Configuration to generate query with                    -> String            -- ^ Schema name string of Database@@ -387,15 +464,7 @@                    -> [Int]             -- ^ Primary key index                    -> Maybe Int         -- ^ Not null key index                    -> Q [Dec]           -- ^ Result declarations-defineTableDefault config schema table columns derives primaryIxs mayNotNullIdx = do-  tblD  <- defineTableTypesAndRecordDefault config schema table columns derives-  let pairT x y = appT (appT (tupleT 2) x) y-      keyType   = foldl1' pairT . map (snd . (columns !!)) $ primaryIxs-  primD <- case primaryIxs of-    []  -> return []-    ixs -> defineWithPrimaryKeyDefault table keyType ixs-  nnD   <- maybeD (\i -> defineWithNotNullKeyDefault table i) mayNotNullIdx-  return $ tblD ++ primD ++ nnD+defineTableDefault = defineTable   -- | Unsafely inlining SQL string 'Query' in compile type.@@ -436,7 +505,7 @@ -- | Generate all templates against defined record like type constructor --   other than depending on sql-value type. makeRelationalRecordDefault :: Name    -- ^ Type constructor name-                             -> Q [Dec] -- ^ Result declaration+                            -> Q [Dec] -- ^ Result declaration makeRelationalRecordDefault recTypeName = do   let recTypeConName = ConName recTypeName   ((tyCon, dataCon), (mayNs, cts)) <- Record.reifyRecordType recTypeName

@@ -24,7 +24,9 @@   updateSQL,    -- * Typed insert statement-  Insert (..), unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert,+  Insert (..), untypeChunkInsert, chunkSizeOfInsert,+  unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert,+  typedInsertValue', typedInsertValue, derivedInsertValue', derivedInsertValue,   InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', typedInsertQuery, derivedInsertQuery,    insertQuerySQL,@@ -46,10 +48,11 @@ import Database.Relational.Query.Monad.BaseType (Relation, sqlFromRelationWith) import Database.Relational.Query.Monad.Restrict (RestrictedStatement) import Database.Relational.Query.Monad.Assign (AssignStatement)+import Database.Relational.Query.Monad.Register (Register) import Database.Relational.Query.Relation (tableOf) import Database.Relational.Query.Effect-  (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn',-   sqlWhereFromRestriction, sqlFromUpdateTarget)+  (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget',+   sqlWhereFromRestriction, sqlFromUpdateTarget, sqlFromInsertTarget) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Component (Config (chunksInsertSize), defaultConfig) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)@@ -172,18 +175,25 @@ -- | Insert type to insert record type 'a'. data Insert a   =   Insert-  { untypeInsert :: String-  , untypeChunkInsert :: String-  , chunkSizeOfInsert :: Int+  { untypeInsert  :: String+  , chunkedInsert :: Maybe (String, Int)   } +-- | Statement to use chunked insert+untypeChunkInsert :: Insert a -> String+untypeChunkInsert ins = maybe (untypeInsert ins) fst $ chunkedInsert ins++-- | Size to use chunked insert+chunkSizeOfInsert :: Insert a -> Int+chunkSizeOfInsert = maybe 1 snd . chunkedInsert+ -- | Unsafely make typed 'Insert' from single insert and chunked insert SQL. unsafeTypedInsert' :: String -> String -> Int -> Insert a-unsafeTypedInsert' =  Insert+unsafeTypedInsert' s = curry (Insert s . Just)  -- | Unsafely make typed 'Insert' from single insert SQL. unsafeTypedInsert :: String -> Insert a-unsafeTypedInsert q = unsafeTypedInsert' q q 1+unsafeTypedInsert s = Insert s Nothing  -- | Make typed 'Insert' from 'Table' and columns selector 'Pi' with configuration parameter. typedInsert' :: Config -> Table r -> Pi r r' -> Insert r'@@ -197,6 +207,26 @@ -- | Table type inferred 'Insert'. derivedInsert :: TableDerivable r => Pi r r' -> Insert r' derivedInsert =  typedInsert derivedTable++-- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object.+typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p+typedInsertValue' config tbl  =+  unsafeTypedInsert . showStringSQL . sqlFromInsertTarget config tbl++-- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object.+typedInsertValue :: Table r -> InsertTarget p r -> Insert p+typedInsertValue = typedInsertValue' defaultConfig++-- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object.+derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p+derivedInsertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs+  where+    rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r+    rt =  const derivedTable++-- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object.+derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p+derivedInsertValue = derivedInsertValue' defaultConfig  -- | Show insert SQL string. instance Show (Insert a) where

@@ -77,6 +77,13 @@   intA0' <-# value (0 :: Int32)   return unitPlaceHolder +registerX :: Insert ()+registerX = derivedInsertValue $ do+  intA0' <-# value 1+  strA1' <-# value "Hello"+  strA2' <-# value "World"+  return unitPlaceHolder+ monadic :: [Test] monadic =   [ eqProp "query"      queryX@@ -103,6 +110,8 @@     "SELECT ALL T0.int_a0 AS f0 FROM TEST.set_a T0"   , eqProp "update"      assignX     "UPDATE TEST.set_a SET int_a0 = 0"+  , eqProp "insert"      registerX+    "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (1, 'Hello', 'World')"   ]  _p_monadic :: IO ()