relational-query 0.8.8.0 → 0.9.0.0

raw patch · 32 files changed

+571/−1005 lines, 32 filesdep +ghc-primdep ~persistable-recorddep ~sql-wordsPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-prim

Dependency ranges changed: persistable-record, sql-words

API changes (from Hackage documentation)

Files

• ChangeLog.md +16/−38
• relational-query.cabal +19/−7
• src/Database/Relational/Query.hs +14/−11
• src/Database/Relational/Query/Arrow.hs +5/−29
• src/Database/Relational/Query/BaseTH.hs +85/−0
• src/Database/Relational/Query/Component.hs +2/−2
• src/Database/Relational/Query/Constraint.hs +2/−2
• src/Database/Relational/Query/Derives.hs +2/−2
• src/Database/Relational/Query/Effect.hs +10/−43
• src/Database/Relational/Query/Internal/BaseSQL.hs +9/−29
• src/Database/Relational/Query/Internal/Sub.hs +0/−46
• src/Database/Relational/Query/Monad/BaseType.hs +2/−10
• src/Database/Relational/Query/Monad/Trans/Assigning.hs +2/−2
• src/Database/Relational/Query/Monad/Trans/Ordering.hs +11/−19
• src/Database/Relational/Query/Pi.hs +4/−5
• src/Database/Relational/Query/Pi/Unsafe.hs +37/−61
• src/Database/Relational/Query/Projectable.hs +67/−115
• src/Database/Relational/Query/ProjectableClass.hs +85/−0
• src/Database/Relational/Query/ProjectableExtended.hs +6/−10
• src/Database/Relational/Query/Projection.hs +21/−23
• src/Database/Relational/Query/Pure.hs +19/−52
• src/Database/Relational/Query/Relation.hs +4/−3
• src/Database/Relational/Query/SQL.hs +26/−11
• src/Database/Relational/Query/Sub.hs +3/−19
• src/Database/Relational/Query/TH.hs +22/−88
• src/Database/Relational/Query/Table.hs +2/−6
• src/Database/Relational/Query/TupleInstances.hs +28/−0
• src/Database/Relational/Query/Type.hs +13/−51
• test/Lex.hs +4/−4
• test/Model.hs +8/−6
• test/sqlsEq.hs +12/−112
• test/sqlsEqArrow.hs +31/−199

@@ -1,44 +1,9 @@ <!-- -*- Markdown -*- --> -## 0.8.8.0--- export QuerySuffix and unsafe-query functions from-  Database.Relational.Query namespace for libraries.--## 0.8.7.1--- fix version constraint.--## 0.8.7.0--- add NULLS FIRST and NULLS LAST to ORDER BY clause.--## 0.8.6.0--- add Show instance of Pi.-- add pzero and ConstantTermsSQL instance of ().-- add Category instance of Pi.--## 0.8.5.1--- add tested-with 8.2.1.--## 0.8.5.0--- Add derivedInsertValue definitions to arrow interface.-- Apply chunked-insert to derivedInsertValue.--## 0.8.4.0--- Fix of unsafeValueNull. ( https://github.com/khibino/haskell-relational-record/issues/55 )--## 0.8.3.8--- Bugfix of case projected record. ( https://github.com/khibino/haskell-relational-record/issues/54 )--## 0.8.3.7+## 0.9.0.0 -- Add version constraint for LTS-8.+- Add HRR instances of tuple types derived by generic programming.+- Add generic instances of ShowConstantTermsSQL.  ## 0.8.3.6 @@ -193,3 +158,16 @@   https://github.com/khibino/haskell-relational-record/pull/15 - Fix for "invalid single-column insert syntax".   https://github.com/khibino/haskell-relational-record/issues/16++## 0.4.0.0++- Extend derivedInsert.++## 0.3.0.0++- Add generalized restrict.+- Pass configuration to DELETE and UPDATE.++## 0.2.0.0++- Update structure of query with placeholders.

@@ -1,5 +1,5 @@ name:                relational-query-version:             0.8.8.0+version:             0.9.0.0 synopsis:            Typeful, Modular, Relational, algebraic query engine description:         This package contiains typeful relation structure and                      relational-algebraic query building DSL which can@@ -18,14 +18,17 @@ category:            Database build-type:          Simple cabal-version:       >=1.10-tested-with:           GHC == 8.2.1-                     , GHC == 8.0.1, GHC == 8.0.2+tested-with:           GHC == 8.0.1, GHC == 8.0.2                      , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3                      , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4                      , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3                      , GHC == 7.4.1, GHC == 7.4.2 extra-source-files:  ChangeLog.md +flag ghc74-generic+  description: Enable for generic programming using old ghc. If true use ghc-prim.+  default:     False+ library   exposed-modules:                        Database.Relational.Query.Arrow@@ -38,11 +41,13 @@                        Database.Relational.Query.Pi.Unsafe                        Database.Relational.Query.Constraint                        Database.Relational.Query.Context-                       Database.Relational.Query.Projectable-                       Database.Relational.Query.ProjectableExtended                        Database.Relational.Query.Component                        Database.Relational.Query.Sub                        Database.Relational.Query.Projection+                       Database.Relational.Query.ProjectableClass+                       Database.Relational.Query.Projectable+                       Database.Relational.Query.ProjectableExtended+                       Database.Relational.Query.TupleInstances                        Database.Relational.Query.Monad.BaseType                        Database.Relational.Query.Monad.Class                        Database.Relational.Query.Monad.Trans.Ordering@@ -63,6 +68,7 @@                        Database.Relational.Query.Scalar                        Database.Relational.Query.Type                        Database.Relational.Query.Derives+                       Database.Relational.Query.BaseTH                        Database.Relational.Query.TH    other-modules:@@ -88,9 +94,11 @@                        , dlist                        , template-haskell                        , th-reify-compat-                       , sql-words >=0.1.5+                       , sql-words >=0.1.4                        , names-th-                       , persistable-record >=0.4.2 && <0.5+                       , persistable-record >= 0.5+  if flag(ghc74-generic)+    build-depends:        ghc-prim == 0.2.*    hs-source-dirs:      src   ghc-options:         -Wall -fsimpl-tick-factor=200@@ -103,6 +111,8 @@                        , relational-query                        , containers                        , transformers+  if flag(ghc74-generic)+    build-depends:        ghc-prim == 0.2.*    type:                exitcode-stdio-1.0   main-is:             sqlsEq.hs@@ -121,6 +131,8 @@                        , relational-query                        , containers                        , transformers+  if flag(ghc74-generic)+    build-depends:        ghc-prim == 0.2.*    type:                exitcode-stdio-1.0   main-is:             sqlsEqArrow.hs

@@ -1,6 +1,6 @@ -- | -- Module      : Database.Relational.Query--- Copyright   : 2013 Kei Hibino+-- Copyright   : 2013-2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -11,20 +11,21 @@ module Database.Relational.Query (   module Database.Relational.Query.Table,   module Database.Relational.Query.SQL,-  module Database.Relational.Query.Pure,   module Database.Relational.Query.Pi,   module Database.Relational.Query.Constraint,   module Database.Relational.Query.Context,   module Database.Relational.Query.Component,   module Database.Relational.Query.Sub,   module Database.Relational.Query.Projection,+  module Database.Relational.Query.ProjectableClass,   module Database.Relational.Query.Projectable,   module Database.Relational.Query.ProjectableExtended,+  module Database.Relational.Query.TupleInstances,+  module Database.Relational.Query.Monad.BaseType,   module Database.Relational.Query.Monad.Class,-  module Database.Relational.Query.Monad.Trans.Aggregating,   module Database.Relational.Query.Monad.Trans.Ordering,+  module Database.Relational.Query.Monad.Trans.Aggregating,   module Database.Relational.Query.Monad.Trans.Assigning,-  module Database.Relational.Query.Monad.BaseType,   module Database.Relational.Query.Monad.Type,   module Database.Relational.Query.Monad.Simple,   module Database.Relational.Query.Monad.Aggregate,@@ -40,8 +41,8 @@   ) 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.SQL (updateOtherThanKeySQL, insertSQL)+import Database.Relational.Query.Pure () import Database.Relational.Query.Pi import Database.Relational.Query.Constraint   (Key, tableConstraint, projectionKey,@@ -53,11 +54,14 @@ import Database.Relational.Query.Component   (NameConfig (..), SchemaNameMode (..), ProductUnitSupport (..), IdentifierQuotation (..),    Config (..), defaultConfig,-   AggregateKey, Order (..), Nulls (..))+   AggregateKey, Order (..)) import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth) import Database.Relational.Query.Projection (Projection, list)+import Database.Relational.Query.ProjectableClass import Database.Relational.Query.Projectable import Database.Relational.Query.ProjectableExtended+import Database.Relational.Query.TupleInstances+import Database.Relational.Query.Monad.BaseType import Database.Relational.Query.Monad.Class   (MonadQualify,    MonadRestrict, wheres, having, restrict,@@ -65,11 +69,10 @@    MonadQuery, query', queryMaybe',    MonadPartition, partitionBy,    distinct, all', on)+import Database.Relational.Query.Monad.Trans.Ordering (orderBy, asc, desc) import Database.Relational.Query.Monad.Trans.Aggregating   (key, key', set, bkey, rollup, cube, groupingSets)-import Database.Relational.Query.Monad.Trans.Ordering (orderBy', orderBy, asc, desc) import Database.Relational.Query.Monad.Trans.Assigning (assignTo, (<-#))-import Database.Relational.Query.Monad.BaseType import Database.Relational.Query.Monad.Type import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) import Database.Relational.Query.Monad.Aggregate@@ -81,8 +84,8 @@ import Database.Relational.Query.Relation import Database.Relational.Query.Scalar (ScalarDegree) import Database.Relational.Query.Type hiding-  (unsafeTypedKeyUpdate, unsafeTypedDelete,-   unsafeTypedInsert, unsafeTypedInsertQuery, )+  (unsafeTypedQuery, unsafeTypedKeyUpdate, unsafeTypedUpdate,+   unsafeTypedInsert, unsafeTypedInsertQuery, unsafeTypedDelete) import Database.Relational.Query.Effect import Database.Relational.Query.Derives 

@@ -41,14 +41,13 @@    groupBy', key, key', set, bkey, rollup, cube, groupingSets, -  orderBy', orderBy, asc, desc,+  orderBy, asc, desc,    partitionBy, over,    assign,    derivedUpdate', derivedUpdate,-  derivedInsertValue', derivedInsertValue,   derivedDelete', derivedDelete,    QueryA,@@ -59,7 +58,7 @@    Orderings, Window, Assignings, -  AssignStatement, Register, RestrictedStatement,+  AssignStatement, RestrictedStatement,   ) where  import Control.Category (Category)@@ -75,11 +74,9 @@    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)+   orderBy, asc, desc, partitionBy, over,+   derivedUpdate', derivedUpdate, derivedDelete', derivedDelete,+   QuerySimple, QueryAggregate, QueryUnique, Window) import qualified Database.Relational.Query as Monadic import Database.Relational.Query.Projection (ListProjection) import qualified Database.Relational.Query.Monad.Trans.Aggregating as Monadic@@ -129,9 +126,6 @@ -- | 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 @@ -370,14 +364,6 @@ 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@@ -426,16 +412,6 @@ --   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.

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

@@ -16,12 +16,12 @@          AggregateKey,           -- * Types for ordering-         Order (..), Nulls (..),+         Order (..),        ) 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.BaseSQL (Order (..),) import Database.Relational.Query.Internal.GroupingSQL (AggregateKey)

@@ -102,12 +102,12 @@   -- | Infer constraint key.   constraintKey :: Key c r ct --- | Inferred 'Unique' constraint 'Key'.+-- | Infered 'Unique' constraint 'Key'. --   Record type 'r' has unique key which type is 'ct' derived from primay key. derivedUniqueKey :: HasConstraintKey Primary r ct => Key Unique r ct derivedUniqueKey =  uniqueKey constraintKey --- -- | Inferred 'NotNull' constraint 'Key'.+-- -- | Infered 'NotNull' constraint 'Key'. -- --   Record type 'r' has not-null key which type is 'ct' derived from primay key. -- derivedNotNullKey :: HasConstraintKey Primary r ct => Key NotNull r ct -- derivedNotNullKey =  notNullKey constraintKey

@@ -38,7 +38,7 @@ 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.Monad.BaseType (Relation) import Database.Relational.Query.Relation   (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) import Database.Relational.Query.Constraint@@ -55,7 +55,7 @@       -> 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)+  (param, ()) <- placeholder (\ph -> wheres $ q ! key .=. ph)   return (param, q)  -- | Query restricted with specified unique key.

@@ -19,33 +19,30 @@   updateTargetAllColumn, updateTargetAllColumn',    -- * Object to express insert terget.-  InsertTarget, insertTarget, insertTarget', piRegister,+  InsertTarget, insertTarget, insertTarget',    -- * Generate SQL from restriction.   sqlWhereFromRestriction,   sqlFromUpdateTarget,-  sqlChunkFromInsertTarget,-  sqlFromInsertTarget,+  sqlFromInsertTarget   ) where  import Data.Monoid ((<>))  import Language.SQL.Keyword (Keyword(..))-import Database.Record.Persistable (PersistableWidth)+import Database.Record (PersistableWidth) -import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig)+import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)-import Database.Relational.Query.Internal.BaseSQL (composeSets, composeChunkValuesWithColumns)+import Database.Relational.Query.Internal.BaseSQL (composeSets, composeValues) -import Database.Relational.Query.Pi (Pi, id')-import qualified Database.Relational.Query.Pi.Unsafe as Pi+import Database.Relational.Query.Pi (id') 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)+  (PlaceHolders, placeholder, unitPlaceHolder, unsafeAddPlaceHolders, (><), 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@@ -154,37 +151,7 @@               -> 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'+-- | SQL INSERT statement 'StringSQL' string from 'InsertTarget' sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL-sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1+sqlFromInsertTarget config tbl (InsertTarget q) = INSERT <> INTO <> stringSQL (Table.name tbl) <> composeValues (asR tbl)+  where (_ph, asR) = Register.extract q config

@@ -10,9 +10,8 @@ -- 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,+  Order (..), OrderColumn, OrderingTerm, composeOrderBy,+  AssignColumn, AssignTerm, Assignment, composeSets, composeValues,   ) where  import Data.Monoid (Monoid (..), (<>))@@ -37,26 +36,22 @@ -- | 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)+type OrderingTerm = (Order, 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+  showsOt (o, e) = e <> order o   order Asc  = ASC   order Desc = DESC-  nulls NullsFirst = FIRST-  nulls NullsLast  = LAST + -- | Column SQL String of assignment type AssignColumn = StringSQL @@ -75,22 +70,7 @@   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+-- | Compose VALUES clause from ['Assignment'].+composeValues :: [Assignment] -> StringSQL+composeValues as = rowConsStringSQL cs <> VALUES <> rowConsStringSQL vs  where+  (cs, vs) = unzip as

@@ -21,9 +21,6 @@        , JoinProduct, QueryProductTree        , ProductTreeBuilder, ProductBuilder -       , CaseClause (..), WhenClauses(..)-       , caseSearch, case'-        , UntypedProjection, untypedProjectionWidth, ProjectionUnit (..)        , Projection, untypeProjection, typedProjection, projectionWidth        , projectFromColumns, projectFromScalarSubQuery@@ -119,23 +116,12 @@ -- | 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.@@ -166,38 +152,6 @@ -- | 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.

@@ -14,7 +14,7 @@          qualifyQuery, askConfig,           -- * Relation type-         Relation, unsafeTypeRelation, untypeRelation, relationWidth,+         Relation, unsafeTypeRelation, untypeRelation,           dump,          sqlFromRelationWith, sqlFromRelation,@@ -25,12 +25,10 @@ import Data.Functor.Identity (Identity, runIdentity) import Control.Applicative ((<$>)) -import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth)- import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) -import Database.Relational.Query.Sub (Qualified, SubQuery, showSQL, width)+import Database.Relational.Query.Sub (Qualified, SubQuery, showSQL) import qualified Database.Relational.Query.Monad.Trans.Qualify as Qualify import Database.Relational.Query.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) import Database.Relational.Query.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig)@@ -61,12 +59,6 @@ -- | 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

@@ -35,7 +35,7 @@  import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Pi (Pi)-import Database.Relational.Query.Table (Table, recordWidth)+import Database.Relational.Query.Table (Table) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..))@@ -63,7 +63,7 @@ type AssignTarget r v = Pi r v  targetProjection :: AssignTarget r v ->  Table r -> Projection Flat v-targetProjection pi' tbl = Projection.wpi (recordWidth tbl) (Projection.unsafeFromTable tbl) pi'+targetProjection pi' tbl = Projection.pi (Projection.unsafeFromTable tbl) pi'  -- | Add an assignment. assignTo :: Monad m => Projection Flat v ->  AssignTarget r v -> Assignings r m ()

@@ -19,7 +19,7 @@   Orderings, orderings,    -- * API of query with ordering-  orderBy', orderBy, asc, desc,+  orderBy, asc, desc,    -- * Result   extractOrderingTerms@@ -32,7 +32,7 @@ import Data.DList (DList, toList)  import Database.Relational.Query.Internal.BaseSQL-  (Order (..), Nulls (..), OrderColumn, OrderingTerm)+  (Order(Asc, Desc), OrderColumn, OrderingTerm)  import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection@@ -84,38 +84,30 @@  -- | Add ordering terms. updateOrderBys :: (Monad m, ProjectableOrdering (Projection c))-               => (Order, Maybe Nulls) -- ^ Order direction-               -> Projection 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` orderTerms p---- | Add ordering terms with null ordering.-orderBy' :: (Monad m, ProjectableOrdering (Projection c))-         => Projection 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+               => Order            -- ^ Order direction+               -> Projection c t   -- ^ Ordering terms to add+               -> Orderings c m () -- ^ Result context with ordering+updateOrderBys order p = Orderings . mapM_ tell $ terms  where+  terms = curry pure order `map` orderTerms p  -- | Add ordering terms. orderBy :: (Monad m, ProjectableOrdering (Projection c))         => Projection c t   -- ^ Ordering terms to add-        -> Order        -- ^ Order direction+        -> Order            -- ^ Order direction         -> Orderings c m () -- ^ Result context with ordering-orderBy p o = updateOrderBys (o, Nothing) p+orderBy = flip updateOrderBys  -- | Add ascendant ordering term. asc :: (Monad m, ProjectableOrdering (Projection c))     => Projection c t   -- ^ Ordering terms to add     -> Orderings c m () -- ^ Result context with ordering-asc  =  updateOrderBys (Asc, Nothing)+asc  =  updateOrderBys Asc  -- | Add descendant ordering term. desc :: (Monad m, ProjectableOrdering (Projection c))      => Projection c t   -- ^ Ordering terms to add      -> Orderings c m () -- ^ Result context with ordering-desc =  updateOrderBys (Desc, Nothing)+desc =  updateOrderBys Desc  -- | Run 'Orderings' to get 'OrderingTerms' extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, [OrderingTerm])

@@ -11,24 +11,23 @@ -- Contains normal interfaces. module Database.Relational.Query.Pi (   -- * Projection path-  Pi, pfmap, pap, pzero, (<.>), (<?.>), (<?.?>),+  Pi, pfmap, pap, (<.>), (<?.>), (<?.?>),    id', fst', snd'   ) where -import qualified Control.Category as Category import Database.Record   (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable   (runPersistableRecordWidth)  import Database.Relational.Query.Pi.Unsafe-  (Pi, pfmap, pap, pzero, (<.>), (<?.>), (<?.?>), definePi)+  (Pi, pfmap, pap, (<.>), (<?.>), (<?.?>), definePi)   -- | Identity projection path.-id' :: Pi a a-id' = Category.id+id' :: PersistableWidth a => Pi a a+id' =  definePi 0  -- | Projection path for fst of tuple. fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst.

@@ -18,9 +18,7 @@    pfmap, pap, -  pzero,--  width', width,+  width,    (<.>), (<?.>), (<?.?>), @@ -28,20 +26,20 @@    definePi, defineDirectPi', defineDirectPi, -  unsafeExpandIndexes',   unsafeExpandIndexes   ) where -import Prelude hiding (pi, (.), id)-import Control.Category (Category (..), (>>>))+import Prelude hiding (pi) import Data.Array (listArray, (!))  import Database.Record.Persistable   (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>),    PersistableWidth (persistableWidth), maybeWidth) -import Database.Relational.Query.Pure (ProductConstructor (..))+import Database.Relational.Query.ProjectableClass+  (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), ) + -- | Projection path primary structure type. data Pi' r0 r1 = Leftest Int                | Map [Int]@@ -56,30 +54,20 @@  -- | 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]+data Pi r0 r1 = Pi (Pi' r0 r1) (PersistableRecordWidth r1) -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)+unsafePiAppend :: (PersistableRecordWidth c' -> PersistableRecordWidth c)+                  -> Pi a b' -> Pi b c' -> Pi a c+unsafePiAppend f (Pi p0 _) (Pi p1 w) =+  Pi (p0 `unsafePiAppend'` p1) (f w)  -- | Unsafely untype key to expand indexes.-unsafeExpandIndexes' :: 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+unsafeExpandIndexes :: Pi a b -> [Int]+unsafeExpandIndexes = d  where+  d (Pi (Map is) _)    = is+  d (Pi (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@@ -88,9 +76,7 @@ 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)+  c (Pi p w)    = Pi (d p) (unsafeCastRecordWidth w)  -- | Projectable fmap of 'Pi' type. pfmap :: ProductConstructor (a -> b)@@ -99,55 +85,45 @@  -- | Projectable ap of 'Pi' type. pap :: Pi r (a -> b) -> Pi r a -> Pi r b-pap pab pb =-   Pi $ \wr ->-   let (_, wab) = runPi pab wr-       (_, wb)  = runPi pb  wr in-   (Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb,-    unsafeCastRecordWidth $ wab <&> wb) {- should switch to safe projectable-applicative -}+pap b@(Pi _ wb) c@(Pi _ wc) =+   Pi+   (Map $ unsafeExpandIndexes b ++ unsafeExpandIndexes c)+   (unsafeCastRecordWidth $ wb <&> wc) --- | 'Pi' with zero width which projects to unit-pzero :: Pi a ()-pzero = Pi $ \_ -> (Map [], persistableWidth)+-- | Compose seed of projection path 'Pi' which has record result type.+instance ProjectableFunctor (Pi a) where+  (|$|) = pfmap +-- | Compose projection path 'Pi' which has record result type using applicative style.+instance ProjectableApplicative (Pi a) where+  (|*|) = pap+ -- | Get record width proof object.-width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct-width' (Pi f) = snd $ f persistableWidth+width' :: Pi r ct -> PersistableRecordWidth ct+width' (Pi _ w) = w  -- | Get record width.-width :: PersistableWidth r => Pi r a -> Int+width :: 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-(<.>) = (>>>)+(<.>) = unsafePiAppend id  -- | Compose projection path. 'Maybe' phantom functor is 'map'-ed. (<?.>) :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c)-(<?.>) = unsafePiAppend justWidth maybeWidth+(<?.>) = unsafePiAppend 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+(<?.?>) = unsafePiAppend 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+pi :: [a] -> Pi r0 r1 -> [a]+pi cs (Pi p' w) = d p'  where+  d (Leftest i) = take (runPersistableRecordWidth w) . drop i $ cs   d (Map is)    = [cs' ! i | i <- is]   cs' = listArray (0, length cs) cs @@ -155,7 +131,7 @@ definePi' :: PersistableRecordWidth r1           -> Int      -- ^ Index of flat SQL value list           -> Pi r0 r1 -- ^ Result projection path-definePi' pw i = Pi $ \_ -> (Leftest i, pw)+definePi' pw i = Pi (Leftest i) pw  -- | Unsafely define projection path from type 'r0' into type 'r1'. --   Use inferred 'PersistableRecordWidth'.@@ -168,7 +144,7 @@ defineDirectPi' :: PersistableRecordWidth r1                 -> [Int]    -- ^ Indexes of flat SQL value list                 -> Pi r0 r1 -- ^ Result projection path-defineDirectPi' pw is = Pi $ \_ -> (Map is, pw)+defineDirectPi' pw is = Pi (Map is) pw  -- | Unsafely define projection path from type 'r0' into type 'r1'. --   Use inferred 'PersistableRecordWidth'.

@@ -14,18 +14,18 @@ -- This module defines operators on various polymorphic projections. module Database.Relational.Query.Projectable (   -- * Projectable from SQL strings-  SqlProjectable (unsafeProjectSqlTerms'), unsafeProjectSql',-  unsafeProjectSqlTerms, unsafeProjectSql,+  SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql',+  unsafeProjectSql,    -- * Projections of values   value,   valueTrue, valueFalse,   values,-  nothing, unsafeValueNull,+  unsafeValueNull,    -- * Placeholders   PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,-  pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH,+  placeholder', placeholder, unitPlaceHolder,    -- * Projectable into SQL strings   ProjectableShowSql (unsafeShowSql'), unsafeShowSql,@@ -59,31 +59,29 @@    -- * 'Maybe' type projecitoins   ProjectableMaybe (just, flattenMaybe),--  -- * ProjectableFunctor and ProjectableApplicative-  ProjectableFunctor (..), ProjectableApplicative (..), ipfmap   ) where  import Prelude hiding (pi)  import Data.String (IsString)+import Data.Monoid ((<>), mconcat)+import Control.Applicative ((<$>))  import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL  import Database.Record-  (PersistableWidth, persistableWidth, PersistableRecordWidth,+  (PersistableWidth, PersistableRecordWidth, derivedWidth,    HasColumnConstraint, NotNull)-import Database.Record.Persistable (runPersistableRecordWidth)  import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)-import qualified Database.Relational.Query.Internal.Sub as Internal +import Database.Relational.Query.ProjectableClass+  (ProjectableFunctor (..), ProjectableApplicative (..), ) import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow)-import Database.Relational.Query.Pure-  (ShowConstantTermsSQL, showConstantTermsSQL', ProductConstructor (..))-import Database.Relational.Query.Pi (Pi)-import qualified Database.Relational.Query.Pi as Pi+import Database.Relational.Query.TupleInstances ()+import Database.Relational.Query.ProjectableClass+  (ShowConstantTermsSQL, showConstantTermsSQL, ) import Database.Relational.Query.Projection   (Projection, ListProjection) import qualified Database.Relational.Query.Projection as Projection@@ -92,26 +90,20 @@ -- | Interface to project SQL terms unsafely. class SqlProjectable p where   -- | Unsafely project from SQL expression terms.-  unsafeProjectSqlTerms' :: [StringSQL] -- ^ SQL expression strings-                         -> p t         -- ^ Result projection object---- | Unsafely project from SQL strings. String interface of 'unsafeProjectSqlTerms''.-unsafeProjectSqlTerms :: SqlProjectable p-                      => [String] -- ^ SQL expression strings-                      -> p t      -- ^ Result projection object-unsafeProjectSqlTerms =  unsafeProjectSqlTerms' . map stringSQL+  unsafeProjectSqlTerms :: [StringSQL] -- ^ SQL expression strings+                        -> p t         -- ^ Result projection object  -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection Flat) where-  unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms+  unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms  -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection Aggregated) where-  unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms+  unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms  -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection OverWindow) where-  unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms+  unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms  class SqlProjectable p => OperatorProjectable p instance OperatorProjectable (Projection Flat)@@ -119,29 +111,19 @@  -- | Unsafely Project single SQL term. unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t-unsafeProjectSql' =  unsafeProjectSqlTerms' . (:[])+unsafeProjectSql' =  unsafeProjectSqlTerms . (:[])  -- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql''. unsafeProjectSql :: SqlProjectable p => String -> p t unsafeProjectSql =  unsafeProjectSql' . stringSQL --- | Polymorphic projection of SQL null value. Semantics of comparing is unsafe.-nothing :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), PersistableWidth a)-        => Projection c (Maybe a)-nothing = proxyWidth persistableWidth-  where-    proxyWidth :: SqlProjectable (Projection c) => PersistableRecordWidth a -> Projection c (Maybe a)-    proxyWidth w = unsafeProjectSqlTerms' $ replicate (runPersistableRecordWidth w) SQL.NULL--{-# DEPRECATED unsafeValueNull "Use `nothing' instead of this." #-}--- | Deprecated. Polymorphic projection of SQL null value.-unsafeValueNull :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), PersistableWidth a)-                => Projection c (Maybe a)-unsafeValueNull = nothing+-- | Polymorphic projection of SQL null value.+unsafeValueNull :: OperatorProjectable p => p (Maybe a)+unsafeValueNull =  unsafeProjectSql "NULL"  -- | Generate polymorphic projection of SQL constant values from Haskell value. value :: (ShowConstantTermsSQL t, OperatorProjectable p) => t -> p t-value =  unsafeProjectSqlTerms' . showConstantTermsSQL'+value = unsafeProjectSqlTerms . showConstantTermsSQL  -- | Polymorphic proejction of SQL true value. valueTrue  :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool)@@ -370,48 +352,59 @@                    => p (Maybe a) -> p (Maybe b) showNumMaybe = unsafeCastProjectable +whensClause :: (OperatorProjectable p, ProjectableShowSql p)+            => String       -- ^ Error tag+            -> [(p a, p b)] -- ^ Each when clauses+            -> p b          -- ^ Else result projection+            -> Keyword      -- ^ Result projection+whensClause eTag cs0 e = d cs0  where+  d []       = error $ eTag ++ ": Empty when clauses!"+  d cs@(_:_) = mconcat [when' p r | (p, r) <- cs] <> else' <> SQL.END+  when' p r = SQL.WHEN <> unsafeShowSql' p <> SQL.THEN <> unsafeShowSql' r+  else'     = SQL.ELSE <> unsafeShowSql' e+ -- | Search case operator correnponding SQL search /CASE/. --   Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/-caseSearch :: OperatorProjectable (Projection c)-           => [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses-           -> Projection c a                                -- ^ Else result projection-           -> Projection c a                                -- ^ Result projection-caseSearch = Internal.caseSearch+caseSearch :: (OperatorProjectable p, ProjectableShowSql p)+           => [(p (Maybe Bool), p a)] -- ^ Each when clauses+           -> p a                     -- ^ Else result projection+           -> p a                     -- ^ Result projection+caseSearch cs e = unsafeProjectSql' $ SQL.CASE <> whensClause "caseSearch" cs e  -- | Same as 'caseSearch', but you can write like <when list> `casesOrElse` <else clause>.-casesOrElse :: OperatorProjectable (Projection c)-            => [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses-            -> Projection c a                                -- ^ Else result projection-            -> Projection c a                                -- ^ Result projection+casesOrElse :: (OperatorProjectable p, ProjectableShowSql p)+            => [(p (Maybe Bool), p a)] -- ^ Each when clauses+            -> p a                     -- ^ Else result projection+            -> p a                     -- ^ Result projection casesOrElse = caseSearch  -- | Null default version of 'caseSearch'.-caseSearchMaybe :: (OperatorProjectable (Projection c) {- (Projection c) is always ProjectableMaybe -}, PersistableWidth a)-                => [(Projection c (Maybe Bool), Projection c (Maybe a))] -- ^ Each when clauses-                -> Projection c (Maybe a)                                -- ^ Result projection+caseSearchMaybe :: (OperatorProjectable p, ProjectableShowSql p)+                => [(p (Maybe Bool), p (Maybe a))] -- ^ Each when clauses+                -> p (Maybe a)                     -- ^ Result projection caseSearchMaybe cs = caseSearch cs unsafeValueNull  -- | Simple case operator correnponding SQL simple /CASE/. --   Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/-case' :: OperatorProjectable (Projection c)-      => 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' = Internal.case'+case' :: (OperatorProjectable p, ProjectableShowSql p)+      => p a          -- ^ Projection value to match+      -> [(p a, p b)] -- ^ Each when clauses+      -> p b          -- ^ Else result projection+      -> p b          -- ^ Result projection+case' v cs e = unsafeProjectSql' $ SQL.CASE <> unsafeShowSql' v <> whensClause "case'" cs e  -- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` <else clause>.-casesOrElse' :: OperatorProjectable (Projection c)-             => (Projection c a, [(Projection c a, Projection c b)]) -- ^ Projection value to match and each when clauses list-             -> Projection c b                                       -- ^ Else result projection-             -> Projection c b                                       -- ^ Result projection+casesOrElse' :: (OperatorProjectable p, ProjectableShowSql p)+             => (p a, [(p a, p b)]) -- ^ Projection value to match and each when clauses list+             -> p b                 -- ^ Else result projection+             -> p b                 -- ^ Result projection casesOrElse' =  uncurry case'  -- | Null default version of 'case''.-caseMaybe :: (OperatorProjectable (Projection c) {- (Projection c) is always ProjectableMaybe -}, PersistableWidth b)-          => Projection c a                             -- ^ Projection value to match-          -> [(Projection c a, Projection c (Maybe b))] -- ^ Each when clauses-          -> Projection c (Maybe b)                     -- ^ Result projection+caseMaybe :: (OperatorProjectable p, ProjectableShowSql p, ProjectableMaybe p)+          => p a                  -- ^ Projection value to match+          -> [(p a, p (Maybe b))] -- ^ Each when clauses+          -> p (Maybe b)          -- ^ Result projection caseMaybe v cs = case' v cs unsafeValueNull  -- | Binary operator corresponding SQL /IN/ .@@ -473,32 +466,23 @@  -- | No placeholder semantics unitPlaceHolder :: PlaceHolders ()-unitPlaceHolder = unsafePlaceHolders---- | No placeholder semantics. Same as `unitPlaceHolder`-unitPH :: PlaceHolders ()-unitPH = unitPlaceHolder+unitPlaceHolder =  unsafePlaceHolders  -- | Unsafely cast placeholder parameter type. unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b unsafeCastPlaceHolders PlaceHolders = PlaceHolders --- | Provide scoped placeholder from width and return its parameter object.-pwPlaceholder :: SqlProjectable p-              => PersistableRecordWidth a-              -> (p a -> b)-              -> (PlaceHolders a, b)-pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw)-  where-    projectPlaceHolder :: SqlProjectable p-                       => PersistableRecordWidth a-                       -> p a-    projectPlaceHolder = unsafeProjectSqlTerms' . (`replicate` "?") . runPersistableRecordWidth+unsafeProjectPlaceHolder' :: (PersistableWidth r, SqlProjectable p)+                               => (PersistableRecordWidth r, p r)+unsafeProjectPlaceHolder' =  unsafeProjectSqlTerms . (`replicate` "?") <$> derivedWidth +unsafeProjectPlaceHolder :: (PersistableWidth r, SqlProjectable p)+                               => p r+unsafeProjectPlaceHolder =  snd unsafeProjectPlaceHolder'  -- | Provide scoped placeholder and return its parameter object. placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) ->  (PlaceHolders t, a)-placeholder' = pwPlaceholder persistableWidth+placeholder' f = (PlaceHolders, f unsafeProjectPlaceHolder)  -- | Provide scoped placeholder and return its parameter object. Monadic version. placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a)@@ -543,21 +527,6 @@   leftId  = unsafeCastPlaceHolders   rightId = unsafeCastPlaceHolders --- | Weaken functor on projections.-class ProjectableFunctor p where-  -- | Method like 'fmap'.-  (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b---- | Same as '|$|' other than using inferred record constructor.-ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b))-       => p a -> p b-ipfmap =  (|$|) productConstructor---- | Weaken applicative functor on projections.-class ProjectableFunctor p => ProjectableApplicative p where-  -- | Method like '<*>'.-  (|*|) :: p (a -> b) -> p a -> p b- -- | Compose seed of record type 'PlaceHolders'. instance ProjectableFunctor PlaceHolders where   _ |$| PlaceHolders = PlaceHolders@@ -566,26 +535,9 @@ instance ProjectableApplicative PlaceHolders where   pf |*| pa = unsafeCastPlaceHolders (pf >< pa) --- | Compose seed of record type 'Projection'.-instance ProjectableFunctor (Projection c) where-  (|$|) = Projection.pfmap---- | Compose record type 'Projection' using applicative style.-instance ProjectableApplicative (Projection c) where-  (|*|) = Projection.pap---- | Compose seed of projection path 'Pi' which has record result type.-instance ProjectableFunctor (Pi a) where-  (|$|) = Pi.pfmap---- | Compose projection path 'Pi' which has record result type using applicative style.-instance ProjectableApplicative (Pi a) where-  (|*|) = Pi.pap- infixl 7 .*., ./., ?*?, ?/? infixl 6 .+., .-., ?+?, ?-? infixl 5 .||., ?||?-infixl 4 |$|, |*| infix  4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'` infixr 3 `and'` infixr 2 `or'`

@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}++-- |+-- Module      : Database.Relational.Query.ProjectableClass+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides interfaces to preserve constraints of+-- direct product projections.+module Database.Relational.Query.ProjectableClass (+  -- * Interface to specify record constructors.+  ProductConstructor (..),++  -- * ProjectableFunctor and ProjectableApplicative+  ProjectableFunctor (..), ProjectableApplicative (..), ipfmap,++  -- * Literal SQL terms+  ShowConstantTermsSQL (..), showConstantTermsSQL,+  StringSQL,++  ) where++import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)+import Data.Monoid (mempty, (<>))+import Data.DList (DList, toList)++import Database.Relational.Query.Internal.SQL (StringSQL)+++-- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'.+class ProductConstructor r where+  -- | The constructor which has type 'r'.+  productConstructor :: r++-- | Weaken functor on projections.+class ProjectableFunctor p where+  -- | Method like 'fmap'.+  (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b++-- | Same as '|$|' other than using inferred record constructor.+ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b))+       => p a -> p b+ipfmap =  (|$|) productConstructor++-- | Weaken applicative functor on projections.+class ProjectableFunctor p => ProjectableApplicative p where+  -- | Method like '<*>'.+  (|*|) :: p (a -> b) -> p a -> p b++infixl 4 |$|, |*|+++showConstantTermsSQL :: ShowConstantTermsSQL a+                     => a+                     -> [StringSQL]+showConstantTermsSQL = toList . showConstantTermsSQL'++-- | Interface for constant SQL term list.+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

@@ -4,7 +4,7 @@  -- | -- Module      : Database.Relational.Query.ProjectableExtended--- Copyright   : 2013-2017 Kei Hibino+-- Copyright   : 2013 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -38,7 +38,6 @@ import Prelude hiding (pi)  import qualified Language.SQL.Keyword as SQL-import Database.Record (PersistableWidth)  import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) import Database.Relational.Query.Projection (Projection)@@ -120,16 +119,14 @@ some' =  unsafeAggregateOp SQL.SOME  -- | Get narrower projection along with projection path.-(!) :: PersistableWidth a-    => Projection c a -- ^ Source projection+(!) :: Projection c a -- ^ Source projection     -> Pi a b         -- ^ Projection path     -> Projection c b -- ^ Narrower projected object (!) = Projection.pi  -- | Get narrower projection along with projection path --   'Maybe' phantom functor is 'map'-ed.-(?!) :: PersistableWidth a-     => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type+(?!) :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type      -> Pi a b                 -- ^ Projection path      -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result (?!) = Projection.piMaybe@@ -137,8 +134,7 @@ -- | Get narrower projection along with projection path --   and project into result projection type. --   Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed.-(?!?) :: PersistableWidth a-      => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type+(?!?) :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type       -> Pi a (Maybe b)         -- ^ Projection path. 'Maybe' type leaf       -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result (?!?) = Projection.piMaybe'@@ -158,14 +154,14 @@   flatten = id  -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path.-flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)+flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)                => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type                -> Pi a b                    -- ^ Projection path                -> Projection cont c         -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type flattenPiMaybe p = flatten . Projection.piMaybe p  -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path.-(!??) :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)+(!??) :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c)       => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type       -> Pi a b                    -- ^ Projection path       -> Projection cont c         -- ^ Narrower flatten and projected object.

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-}  -- |@@ -27,7 +28,6 @@    -- * Projections   pi, piMaybe, piMaybe',-  wpi,    flattenMaybe, just, @@ -45,8 +45,7 @@  import qualified Language.SQL.Keyword as SQL -import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint, PersistableWidth, persistableWidth)-import Database.Record.Persistable (PersistableRecordWidth)+import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint) import qualified Database.Record.KeyConstraint as KeyConstraint  import Database.Relational.Query.Internal.SQL (StringSQL, listStringSQL, )@@ -55,10 +54,11 @@    Projection, untypeProjection, typedProjection, projectionWidth) import qualified Database.Relational.Query.Internal.Sub as Internal +import Database.Relational.Query.ProjectableClass+  (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), ) import Database.Relational.Query.Context (Aggregated, Flat) import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table-import Database.Relational.Query.Pure (ProductConstructor (..)) import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Relational.Query.Sub@@ -105,40 +105,30 @@   -- | Unsafely trace projection path.-unsafeProject :: PersistableRecordWidth a -> Projection c a' -> Pi a b -> Projection c b'-unsafeProject w p pi' =+unsafeProject :: Projection c a' -> Pi a b -> Projection c b'+unsafeProject p pi' =   Internal.projectFromColumns-  . (UnsafePi.pi w pi')+  . (`UnsafePi.pi` pi')   . columns $ p  -- | Trace projection path to get narrower 'Projection'.-wpi :: PersistableRecordWidth a-    -> Projection c a -- ^ Source 'Projection'-    -> Pi a b         -- ^ Projection path-    -> Projection c b -- ^ Narrower 'Projection'-wpi =  unsafeProject---- | Trace projection path to get narrower 'Projection'.-pi :: PersistableWidth a-   => Projection c a -- ^ Source 'Projection'+pi :: Projection c a -- ^ Source 'Projection'    -> Pi a b         -- ^ Projection path    -> Projection c b -- ^ Narrower 'Projection'-pi =  unsafeProject persistableWidth+pi =  unsafeProject  -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type.-piMaybe :: PersistableWidth a-        => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type+piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type         -> Pi a b                 -- ^ Projection path         -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result-piMaybe = unsafeProject persistableWidth+piMaybe =  unsafeProject  -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. --   Leaf type of projection path is 'Maybe'.-piMaybe' :: PersistableWidth a-         => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type+piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type          -> Pi a (Maybe b)         -- ^ Projection path. 'Maybe' type leaf          -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result-piMaybe' = unsafeProject persistableWidth+piMaybe' =  unsafeProject  unsafeCast :: Projection c r -> Projection c r' unsafeCast =  typedProjection . untypeProjection@@ -178,6 +168,14 @@ -- | Projectable ap of 'Projection' type. pap :: Projection c (a -> b) -> Projection c a -> Projection c b pf `pap` pa = typedProjection $ untypeProjection pf ++ untypeProjection pa++-- | Compose seed of record type 'Projection'.+instance ProjectableFunctor (Projection c) where+  (|$|) = pfmap++-- | Compose record type 'Projection' using applicative style.+instance ProjectableApplicative (Projection c) where+  (|*|) = pap  -- | Projection type for row list. data ListProjection p t = List [p t]

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-}  -- |@@ -11,16 +12,10 @@ -- -- This module defines interfaces between haskell pure values -- and query internal projection values.-module Database.Relational.Query.Pure (--  -- * Interface to specify record constructors.-  ProductConstructor (..),--  -- * Constant SQL Terms-  ShowConstantTermsSQL (..), showConstantTermsSQL-  ) where+module Database.Relational.Query.Pure () where -import Data.Monoid (mconcat)+import Control.Applicative (pure)+import Data.Monoid ((<>)) import Data.Int (Int8, Int16, Int32, Int64) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB@@ -32,6 +27,7 @@ import Text.Printf (PrintfArg, printf) import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, formatTime) import Data.Time.Locale.Compat (defaultTimeLocale)+import Data.DList (DList, fromList)  import Language.SQL.Keyword (Keyword (..)) import Database.Record@@ -39,25 +35,14 @@ import Database.Record.Persistable   (runPersistableRecordWidth) -import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)----- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'.-class ProductConstructor r where-  -- | The constructor which has type 'r'.-  productConstructor :: r+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL) --- | ProductConstructor instance of pair.-instance ProductConstructor (a -> b -> (a, b)) where-  productConstructor = (,)+import Database.Relational.Query.ProjectableClass (ShowConstantTermsSQL (..))  --- | Constant integral SQL expression.-intExprSQL :: (Show a, Integral a) => a -> StringSQL-intExprSQL =  stringSQL . show--intTermsSQL :: (Show a, Integral a) => a -> [StringSQL]-intTermsSQL =  (:[]) . intExprSQL+-- | Constant integral SQL terms.+intTermsSQL :: (Show a, Integral a) => a -> DList StringSQL+intTermsSQL =  pure . stringSQL . show  -- | Escape 'String' for constant SQL string expression. escapeStringToSqlExpr :: String -> String@@ -70,20 +55,8 @@ stringExprSQL :: String -> StringSQL stringExprSQL =  stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr -stringTermsSQL :: String -> [StringSQL]-stringTermsSQL =  (:[]) . stringExprSQL---- | Interface for constant SQL term list.-class ShowConstantTermsSQL a where-  showConstantTermsSQL' :: a -> [StringSQL]---- | String interface of 'showConstantTermsSQL''.-showConstantTermsSQL :: ShowConstantTermsSQL a => a -> [String]-showConstantTermsSQL =  map showStringSQL . showConstantTermsSQL'---- | Constant SQL terms of '()'.-instance ShowConstantTermsSQL () where-  showConstantTermsSQL' () = []+stringTermsSQL :: String -> DList StringSQL+stringTermsSQL = pure . stringExprSQL  -- | Constant SQL terms of 'Int8'. instance ShowConstantTermsSQL Int8 where@@ -132,12 +105,12 @@  -- | Constant SQL terms of 'Bool'. instance ShowConstantTermsSQL Bool where-  showConstantTermsSQL' = (:[]) . stringSQL . d  where+  showConstantTermsSQL' = pure . stringSQL . d  where     d True  = "(0=0)"     d False = "(0=1)" -floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> [StringSQL]-floatTerms f = (:[]) . stringSQL $ printf fmt f  where+floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL+floatTerms f = pure . stringSQL $ printf fmt f  where   fmt     | f >= 0    = "%f"     | otherwise = "(%f)"@@ -150,9 +123,8 @@ instance ShowConstantTermsSQL Double where   showConstantTermsSQL' = floatTerms -constantTimeTerms :: FormatTime t => Keyword -> String -> t -> [StringSQL]-constantTimeTerms kw fmt t = [mconcat [kw,-                                       stringExprSQL $ formatTime defaultTimeLocale fmt t]]+constantTimeTerms :: FormatTime t => Keyword -> String -> t -> DList StringSQL+constantTimeTerms kw fmt t = pure $ kw <> stringExprSQL (formatTime defaultTimeLocale fmt t)  -- | Constant SQL terms of 'Day'. instance ShowConstantTermsSQL Day where@@ -176,17 +148,12 @@ instance ShowConstantTermsSQL UTCTime where   showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z" -showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> [StringSQL]+showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL showMaybeTerms wa = d  where   d (Just a) = showConstantTermsSQL' a-  d Nothing  = replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"+  d Nothing  = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL"  -- | Constant SQL terms of 'Maybe' type. Width inference is required. instance (PersistableWidth a, ShowConstantTermsSQL a)          => ShowConstantTermsSQL (Maybe a) where   showConstantTermsSQL' = showMaybeTerms persistableWidth---- | Constant SQL terms of '(a, b)' type.-instance (ShowConstantTermsSQL a, ShowConstantTermsSQL b)-         => ShowConstantTermsSQL (a, b) where-  showConstantTermsSQL' (a, b) = showConstantTermsSQL' a ++ showConstantTermsSQL' b

@@ -47,7 +47,7 @@ import Database.Relational.Query.Context (Flat, Aggregated) import Database.Relational.Query.Monad.BaseType   (ConfigureQuery, qualifyQuery,-   Relation, unsafeTypeRelation, untypeRelation, relationWidth)+   Relation, unsafeTypeRelation, untypeRelation) import Database.Relational.Query.Monad.Class   (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), on) import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery)@@ -66,13 +66,14 @@ import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable   (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, projectZip)+import Database.Relational.Query.ProjectableExtended ((!))   -- | Simple 'Relation' from 'Table'. table :: Table r -> Relation () r table =  unsafeTypeRelation . return . SubQuery.fromTable --- | Inferred 'Relation'.+-- | Infered 'Relation'. derivedRelation :: TableDerivable r => Relation () r derivedRelation =  table derivedTable @@ -370,7 +371,7 @@                  -> UniqueRelation ph Flat b aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do   (ph, a) <- query' rel-  return (ph, ag $ Projection.wpi (relationWidth rel) a k)+  return (ph, ag $ a ! k)  -- | Scalar sub-query with place-holder parameter 'p'. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r)

@@ -20,7 +20,7 @@   updateOtherThanKeySQL', updateOtherThanKeySQL,    -- * Insert SQL-  insertPrefixSQL, insertSQL,+  insertPrefixSQL, insertSQL, insertSizedChunkSQL,    -- * Delete SQL   deletePrefixSQL', deletePrefixSQL@@ -31,7 +31,6 @@  import Language.SQL.Keyword (Keyword(..), (.=.), (|*|)) import qualified Language.SQL.Keyword as SQL-import Database.Record (PersistableWidth) import Database.Record.ToSql (untypedUpdateValuesIndex)  import Database.Relational.Query.Internal.SQL@@ -39,7 +38,7 @@  import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi-import Database.Relational.Query.Table (Table, name, columns, recordWidth)+import Database.Relational.Query.Table (Table, name, columns) import qualified Database.Relational.Query.Projection as Projection  @@ -90,23 +89,39 @@           -> Pi r p  -- ^ Key columns           -> String  -- ^ Result SQL updateOtherThanKeySQL tbl key =-  updateOtherThanKeySQL' (name tbl) (columns tbl) (UnsafePi.unsafeExpandIndexes' (recordWidth tbl) key)+  updateOtherThanKeySQL' (name tbl) (columns tbl) (UnsafePi.unsafeExpandIndexes key)  -- | Generate prefix string of insert SQL. insertPrefixSQL :: Pi r r' -> Table r -> StringSQL insertPrefixSQL pi' table =   INSERT <> INTO <> stringSQL (name table) <> rowConsStringSQL cols  where-    cols = Projection.columns . Projection.wpi (recordWidth table) (Projection.unsafeFromTable table) $ pi'+    cols = Projection.columns . Projection.pi (Projection.unsafeFromTable table) $ pi' -{-# DEPRECATED insertSQL "Deprecated." #-}+-- | Generate records chunk insert SQL.+insertChunkSQL :: Int     -- ^ Records count to insert+               -> Pi r r' -- ^ Columns selector to insert+               -> Table r -- ^ Table metadata+               -> String  -- ^ Result SQL+insertChunkSQL n0 pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs  where+  n | n0 >= 1    =  n0+    | otherwise  =  error $ "Invalid chunk count value: " ++ show n0+  w = UnsafePi.width pi'+  vs = SQL.fold (|*|) . replicate n $ rowConsStringSQL (replicate w "?")++-- | Generate size measured records chunk insert SQL.+insertSizedChunkSQL :: Pi r r'       -- ^ Columns selector to insert+                    -> Table r       -- ^ Table metadata+                    -> Int           -- ^ Chunk size threshold (column count)+                    -> (String, Int) -- ^ Result SQL and records count of chunk+insertSizedChunkSQL pi' tbl th = (insertChunkSQL n pi' tbl, n)  where+  w = UnsafePi.width pi'+  n = th `quot` w + 1+ -- | Generate insert SQL.-insertSQL :: PersistableWidth r-          => Pi r r' -- ^ Columns selector to insert+insertSQL :: Pi r r' -- ^ Columns selector to insert           -> Table r -- ^ Table metadata           -> String  -- ^ Result SQL-insertSQL pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs  where-  w = UnsafePi.width pi'-  vs = rowConsStringSQL (replicate w "?")+insertSQL =  insertChunkSQL 1  -- | Generate all column delete SQL by specified table. Untyped table version. deletePrefixSQL' :: String -> StringSQL

@@ -58,7 +58,6 @@   (AggregateElem, composeGroupBy, ) import Database.Relational.Query.Internal.Sub   (SubQuery (..), Projection,-   CaseClause(..), WhenClauses (..),    UntypedProjection, ProjectionUnit (..),    JoinProduct, QueryProductTree, ProductBuilder,    NodeAttr (Just', Maybe), ProductTree (Leaf, Join),@@ -70,7 +69,8 @@  import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table-import Database.Relational.Query.Pure (showConstantTermsSQL')+import Database.Relational.Query.ProjectableClass (showConstantTermsSQL)+import Database.Relational.Query.Pure ()   showsSetOp' :: SetOp -> StringSQL@@ -243,28 +243,12 @@   d (Flat {})               =  normalized   d (Aggregated {})         =  normalized --- | index result of each when clause and else clause.-indexWhensClause :: WhenClauses -> Int -> StringSQL-indexWhensClause (WhenClauses ps e) i =-    mconcat [ when' p r | (p, r)  <-  ps] <> else' <> SQL.END-  where-    when' p r = SQL.WHEN <> rowStringSQL (map columnOfProjectionUnit p) <>-                SQL.THEN <> columnOfUntypedProjection r i-    else'     = SQL.ELSE <> columnOfUntypedProjection e i---- | index result of each when clause and else clause.-caseClause :: CaseClause -> Int -> StringSQL-caseClause c i = d c  where-  d (CaseSearch wcl)    = SQL.CASE <> indexWhensClause wcl i-  d (CaseSimple m wcl)  = SQL.CASE <> rowStringSQL (map columnOfProjectionUnit m) <> indexWhensClause wcl i- -- | Convert from ProjectionUnit into column. columnOfProjectionUnit :: ProjectionUnit -> StringSQL columnOfProjectionUnit = d  where   d (RawColumn e)     = e   d (SubQueryRef qi)  = Internal.qualifier qi `columnFromId` Internal.unQualify qi   d (Scalar sub)      = showUnitSQL sub-  d (Case c i)        = caseClause c i  -- | Get column SQL string of 'UntypedProjection'. columnOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection'@@ -302,7 +286,7 @@     [urec left',      joinType (Internal.nodeAttr left') (Internal.nodeAttr right'), JOIN,      urec right',-     ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ]+     ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL True | null ps ] ]     where ps = [ unsafeProjectionStringSql p | p <- rs ]  -- | Shows join product of query.

@@ -6,7 +6,7 @@  -- | -- Module      : Database.Relational.Query.TH--- Copyright   : 2013-2016 Kei Hibino+-- Copyright   : 2013-2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -20,7 +20,6 @@ module Database.Relational.Query.TH (   -- * All templates about table   defineTable,-  defineTableDefault,    -- * Inlining typed 'Query'   unsafeInlineQuery,@@ -28,22 +27,21 @@    -- * Column projections and basic 'Relation' for Haskell record   defineTableTypesAndRecord,-  defineTableTypesAndRecordDefault,    -- * Constraint key templates   defineHasPrimaryKeyInstance,   defineHasPrimaryKeyInstanceWithConfig,-  defineHasPrimaryKeyInstanceDefault,   defineHasNotNullKeyInstance,   defineHasNotNullKeyInstanceWithConfig,-  defineHasNotNullKeyInstanceDefault,   defineScalarDegree,    -- * Column projections   defineColumns, defineColumnsDefault, +  defineTuplePi,+   -- * Table metadata type and basic 'Relation'-  defineTableTypes, defineTableTypesWithConfig, defineTableTypesDefault,+  defineTableTypes, defineTableTypesWithConfig,    -- * Basic SQL templates generate rules   definePrimaryQuery,@@ -53,7 +51,6 @@   derivationExpDefault,   tableVarExpDefault,   relationVarExp,-  relationVarExpDefault,    -- * Derived SQL templates from table definitions   defineSqlsWithPrimaryKey,@@ -73,25 +70,26 @@  import Language.Haskell.TH   (Name, nameBase, Q, reify, TypeQ, Type (AppT, ConT), ExpQ,-   tupleT, appT, arrowT, Dec, stringE, listE)+   tupleT, appT, Dec, stringE, listE) import Language.Haskell.TH.Compat.Reify (unVarI) import Language.Haskell.TH.Name.CamelCase-  (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon, toDataCon)+  (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon) import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE)  import Database.Record.TH-  (columnOffsetsVarNameDefault, recordTypeName, recordType,+  (columnOffsetsVarNameDefault, recordTypeName, recordTemplate,    defineRecordTypeWithConfig, defineHasColumnConstraintInstance) import qualified Database.Record.TH as Record  import Database.Relational.Query-  (Table, Pi, id', Relation, ProductConstructor (..),+  (Table, Pi, id', Relation, ShowConstantTermsSQL,    NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..),-   Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation), defaultConfig,+   Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation),    relationalQuerySQL, Query, relationalQuery, KeyUpdate,    Insert, derivedInsert, InsertQuery, derivedInsertQuery,    HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate) +import Database.Relational.Query.BaseTH (defineProductConstructorInstance, defineTuplePi) import Database.Relational.Query.Scalar (defineScalarDegree) import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey) import Database.Relational.Query.Table (TableDerivable (..))@@ -133,17 +131,7 @@                                       -> [Int]   -- ^ Primary key index                                       -> Q [Dec] -- ^ Declarations of primary constraint key defineHasPrimaryKeyInstanceWithConfig config scm =-  defineHasPrimaryKeyInstance . recordType (recordConfig $ nameConfig config) scm--{-# DEPRECATED defineHasPrimaryKeyInstanceDefault "Use ' defineHasPrimaryKeyInstanceWithConfig defaultConfig ' instead of this." #-}--- | Rule template to infer primary key.-defineHasPrimaryKeyInstanceDefault :: String  -- ^ Schema name-                                   -> String  -- ^ Table name-                                   -> TypeQ   -- ^ Column type-                                   -> [Int]   -- ^ Primary key index-                                   -> Q [Dec] -- ^ Declarations of primary constraint key-defineHasPrimaryKeyInstanceDefault =-  defineHasPrimaryKeyInstanceWithConfig defaultConfig+  defineHasPrimaryKeyInstance . fst . recordTemplate (recordConfig $ nameConfig config) scm  -- | Rule template to infer not-null key. defineHasNotNullKeyInstance :: TypeQ   -- ^ Record type@@ -159,16 +147,7 @@                                       -> Int     -- ^ NotNull key index                                       -> Q [Dec] -- ^ Declaration of not-null constraint key defineHasNotNullKeyInstanceWithConfig config scm =-  defineHasNotNullKeyInstance . recordType (recordConfig $ nameConfig config) scm--{-# DEPRECATED defineHasNotNullKeyInstanceDefault "Use ' defineHasNotNullKeyInstanceWithConfig defaultConfig ' instead of this." #-}--- | Rule template to infer not-null key.-defineHasNotNullKeyInstanceDefault :: String  -- ^ Schema name-                                   -> String  -- ^ Table name-                                   -> Int     -- ^ NotNull key index-                                   -> Q [Dec] -- ^ Declaration of not-null constraint key-defineHasNotNullKeyInstanceDefault =-  defineHasNotNullKeyInstanceWithConfig defaultConfig+  defineHasNotNullKeyInstance . fst . recordTemplate (recordConfig $ nameConfig config) scm   -- | Column projection path 'Pi' template.@@ -301,28 +280,11 @@                          -> ExpQ   -- ^ Result var Exp relationVarExp config scm = toVarExp . relationVarName (nameConfig config) scm -{-# DEPRECATED relationVarExpDefault "Use ' relationVarExp defaultConfig ' instead of this." #-}--- | Make 'Relation' variable expression template from table name using default naming rule.-relationVarExpDefault :: String -- ^ Schema name string-                      -> String -- ^ Table name string-                      -> ExpQ   -- ^ Result var Exp-relationVarExpDefault = relationVarExp defaultConfig---- | Make template for 'ProductConstructor' instance.-defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]-defineProductConstructorInstance recTypeQ recData colTypes =-  [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where-        productConstructor = $(recData)-    |]- -- | Make template for record 'ProductConstructor' instance using specified naming rule. defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec] defineProductConstructorInstanceWithConfig config schema table colTypes = do-  let typeName = recordTypeName (recordConfig $ nameConfig config) schema table-  defineProductConstructorInstance-    (toTypeCon typeName)-    (toDataCon typeName)-    colTypes+  let tp = recordTemplate (recordConfig $ nameConfig config) schema table+  uncurry defineProductConstructorInstance tp colTypes  -- | Make templates about table and column metadatas using specified naming rule. defineTableTypesWithConfig :: Config                           -- ^ Configuration to generate query with@@ -338,21 +300,12 @@              (relationVarName nmconfig schema table)              (table `varNameWithPrefix` "insert")              (table `varNameWithPrefix` "insertQuery")-             (recordType recConfig schema table)+             (fst $ recordTemplate recConfig schema table)              (tableSQL (normalizedTableName config) (schemaNameMode config) (identifierQuotation config) schema table)              (map ((quote (identifierQuotation config)) . fst . fst) columns)   colsDs <- defineColumnsDefault (recordTypeName recConfig schema table) columns   return $ tableDs ++ colsDs -{-# DEPRECATED defineTableTypesDefault "Use defineTableTypesWithConfig instead of this." #-}--- | Make templates about table and column metadatas using default naming rule.-defineTableTypesDefault :: Config                           -- ^ Configuration to generate query with-                        -> String                           -- ^ Schema name-                        -> String                           -- ^ Table name-                        -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type-                        -> Q [Dec]                          -- ^ Result declarations-defineTableTypesDefault = defineTableTypesWithConfig- -- | Make templates about table, column and haskell record using specified naming rule. defineTableTypesAndRecord :: Config            -- ^ Configuration to generate query with                           -> String            -- ^ Schema name@@ -361,20 +314,12 @@                           -> [Name]            -- ^ Record derivings                           -> Q [Dec]           -- ^ Result declarations defineTableTypesAndRecord config schema table columns derives = do-  recD    <- defineRecordTypeWithConfig (recordConfig $ nameConfig config) schema table columns derives+  let recConfig = recordConfig $ nameConfig config+  recD    <- defineRecordTypeWithConfig recConfig schema table columns derives   rconD   <- defineProductConstructorInstanceWithConfig config schema table [t | (_, t) <- columns]+  ctD     <- [d| instance ShowConstantTermsSQL $(fst $ recordTemplate recConfig schema table) |]   tableDs <- defineTableTypesWithConfig config schema table [(c, Nothing) | c <- columns ]-  return $ recD ++ rconD ++ tableDs--{-# DEPRECATED defineTableTypesAndRecordDefault "Use defineTableTypesAndRecord instead of this." #-}--- | Make templates about table, column and haskell record using default naming rule.-defineTableTypesAndRecordDefault :: Config            -- ^ Configuration to generate query with-                                 -> String            -- ^ Schema name-                                 -> String            -- ^ Table name-                                 -> [(String, TypeQ)] -- ^ Column names and types-                                 -> [Name]            -- ^ Record derivings-                                 -> Q [Dec]           -- ^ Result declarations-defineTableTypesAndRecordDefault = defineTableTypesAndRecord+  return $ recD ++ rconD ++ ctD ++ tableDs  -- | Template of derived primary 'Query'. definePrimaryQuery :: VarName -- ^ Variable name of result declaration@@ -436,7 +381,7 @@                      -> Q [Dec] -- ^ Result declarations defineWithPrimaryKey config schema table keyType ixs = do   instD <- defineHasPrimaryKeyInstanceWithConfig config schema table keyType ixs-  let recType  = recordType (recordConfig $ nameConfig config) schema table+  let recType  = fst $ recordTemplate (recordConfig $ nameConfig config) schema table       tableE   = tableVarExpDefault table       relE     = relationVarExp config schema table   sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE@@ -465,19 +410,7 @@   nnD   <- maybeD (\i -> defineWithNotNullKeyWithConfig config schema table i) mayNotNullIdx   return $ tblD ++ primD ++ nnD -{-# DEPRECATED defineTableDefault "Use defineTable instead of this." #-}--- | Generate all templtes about table using default naming rule.-defineTableDefault :: Config            -- ^ Configuration to generate query with-                   -> String            -- ^ Schema name string of Database-                   -> String            -- ^ Table name string of Database-                   -> [(String, TypeQ)] -- ^ Column names and types-                   -> [Name]            -- ^ derivings for Record type-                   -> [Int]             -- ^ Primary key index-                   -> Maybe Int         -- ^ Not null key index-                   -> Q [Dec]           -- ^ Result declarations-defineTableDefault = defineTable - -- | Unsafely inlining SQL string 'Query' in compile type. unsafeInlineQuery :: TypeQ   -- ^ Query parameter type                   -> TypeQ   -- ^ Query result type@@ -527,4 +460,5 @@                 [ ((nameBase n, ct), Nothing) | n  <- ns  | ct <- cts ])         mayNs   pc <- defineProductConstructorInstance tyCon dataCon cts-  return $ concat [pw, cs, pc]+  ct <- [d| instance ShowConstantTermsSQL $tyCon |]+  return $ concat [pw, cs, pc, ct]

@@ -10,7 +10,7 @@ -- This module defines table type which has table metadatas. module Database.Relational.Query.Table (   -- * Phantom typed table type-  Table, unType, name, shortName, width, columns, index, table, toMaybe, recordWidth,+  Table, unType, name, shortName, width, columns, index, table, toMaybe,    -- * Table existence inference   TableDerivable (..)@@ -18,7 +18,7 @@  import Data.Array (listArray) -import Database.Record.Persistable (PersistableWidth, PersistableRecordWidth, unsafePersistableRecordWidth)+import Database.Record (PersistableWidth)  import Database.Relational.Query.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!)) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, )@@ -66,7 +66,3 @@ -- | Inference rule of 'Table' existence. class PersistableWidth r => TableDerivable r where   derivedTable :: Table r---- | PersistableRecordWidth of table-recordWidth :: Table r -> PersistableRecordWidth r-recordWidth = unsafePersistableRecordWidth . width

@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Database.Relational.Query.TupleInstances+-- Copyright   : 2017 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module defines ProductConstructor instances and projection path objects of tuple types.+module Database.Relational.Query.TupleInstances where++import Control.Applicative ((<$>))++import Database.Relational.Query.BaseTH+  (defineTuplePi, defineTupleProductConstructor, defineTupleShowConstantInstance,)+++$(concat <$> mapM defineTupleProductConstructor [2..7])+$(concat <$> mapM defineTuplePi [2..7])+$(concat <$> mapM defineTupleShowConstantInstance [2..7])+-- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics.

@@ -17,10 +17,9 @@   relationalQuerySQL,    -- * Typed update statement-  KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, derivedKeyUpdate,+  KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable,   Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate,-  typedUpdateAllColumn, derivedUpdateAllColumn', derivedUpdateAllColumn,-  restrictedUpdateAllColumn, restrictedUpdateTableAllColumn,+  typedUpdateAllColumn, restrictedUpdateAllColumn, restrictedUpdateTableAllColumn,    updateSQL, @@ -45,7 +44,7 @@  import Database.Record (PersistableWidth) -import Database.Relational.Query.Internal.Config (Config, defaultConfig)+import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig) import Database.Relational.Query.Internal.SQL (showStringSQL)  import Database.Relational.Query.Monad.BaseType (Relation, sqlFromRelationWith)@@ -55,12 +54,12 @@ import Database.Relational.Query.Relation (tableOf) import Database.Relational.Query.Effect   (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget',-   sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget)+   sqlWhereFromRestriction, sqlFromUpdateTarget, sqlFromInsertTarget) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.SQL-  (QuerySuffix, showsQuerySuffix, insertPrefixSQL,+  (QuerySuffix, showsQuerySuffix, insertPrefixSQL, insertSQL, insertSizedChunkSQL,    updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL)  @@ -108,13 +107,6 @@ typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r typedKeyUpdateTable =  typedKeyUpdate . tableOf --- derivedKeyUpdate'--- Config parameter is not yet required for KeyUpdate.---- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'.-derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r-derivedKeyUpdate = typedKeyUpdate derivedTable- -- | Show update SQL string instance Show (KeyUpdate p a) where   show = untypeKeyUpdate@@ -152,15 +144,6 @@ derivedUpdate = derivedUpdate' defaultConfig  --- | Make typed 'Update' from 'Config', 'Table' and 'Restriction'.---   Update target is all column.-typedUpdateAllColumn' :: PersistableWidth r-                      => Config-                      -> Table r-                      -> Restriction p r-                      -> Update (r, p)-typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r- -- | Make typed 'Update' from 'Table' and 'Restriction'. --   Update target is all column. typedUpdateAllColumn :: PersistableWidth r@@ -169,22 +152,6 @@                      -> Update (r, p) typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r --- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'.---   Update target is all column.-derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r)-                        => Config-                        -> RestrictedStatement r (PlaceHolders p)-                        -> Update (r, p)-derivedUpdateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction'---- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'.---   Update target is all column.-derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r)-                       => RestrictedStatement r (PlaceHolders p)-                       -> Update (r, p)-derivedUpdateAllColumn = derivedUpdateAllColumn' defaultConfig--{-# DEPRECATED restrictedUpdateAllColumn "Use derivedUpdateAllColumn or typedUpdateAllColumn instead of this." #-} -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. --   Update target is all column. restrictedUpdateAllColumn :: PersistableWidth r@@ -193,7 +160,6 @@                            -> Update (r, p) restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction' -{-# DEPRECATED restrictedUpdateTableAllColumn "Use derivedUpdateAllColumn or typedUpdateAllColumn instead of this." #-} -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. --   Update target is all column. restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r)@@ -231,26 +197,22 @@ unsafeTypedInsert s = Insert s Nothing  -- | Make typed 'Insert' from 'Table' and columns selector 'Pi' with configuration parameter.-typedInsert' :: PersistableWidth r => Config -> Table r -> Pi r r' -> Insert r'-typedInsert' config tbl =-  typedInsertValue' config tbl . insertTarget' . piRegister+typedInsert' :: Config -> Table r -> Pi r r' -> Insert r'+typedInsert' config tbl pi' = unsafeTypedInsert' (insertSQL pi' tbl) ci n  where+  (ci, n) = insertSizedChunkSQL pi' tbl $ chunksInsertSize config  -- | Make typed 'Insert' from 'Table' and columns selector 'Pi'.-typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r'+typedInsert :: Table r -> Pi r r' -> Insert r' typedInsert =  typedInsert' defaultConfig  -- | Table type inferred 'Insert'.-derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'-derivedInsert = typedInsert derivedTable+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 it =-    unsafeTypedInsert'-    (showStringSQL $ sqlFromInsertTarget config tbl it)-    (showStringSQL ci) n-  where-    (ci, n) = sqlChunkFromInsertTarget config tbl it+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

@@ -1,4 +1,4 @@-module Lex (eqProp, eqProp') where+module Lex (eqProp) where  import Control.Applicative   ((<$>), (<*>), pure, (*>), (<*), (<|>), empty, many, some)@@ -181,9 +181,9 @@   y <- run b   return $ x == y -eqProp' :: String -> (a -> String) -> a -> String -> Test-eqProp' name fstr x est = boolTest' name em (fstr x `eq` est)-  where em = unlines [show $ run $ fstr x, " -- compares --", show $ run est]+eqProp' :: String -> (t -> String) -> t -> String -> Test+eqProp' name t x est = boolTest' name em (t x `eq` est)+  where em = unlines [show $ run $ t x, " -- compares --", show $ run est]  eqProp :: Show a => String -> a -> String -> Test eqProp name = eqProp' name show

@@ -2,9 +2,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric #-}  module Model where +import GHC.Generics (Generic) import Data.Int (Int32, Int64)  import Database.Relational.Query (defaultConfig)@@ -15,14 +17,14 @@   [ ("int_a0" ,    [t| Int32  |])   , ("str_a1" ,    [t| String |])   , ("str_a2" ,    [t| String |]) ]-  [] [0] $ Just 0)+  [''Generic] [0] $ Just 0)   $(defineTable defaultConfig "TEST" "set_b"   [ ("int_b0" ,    [t| Int32  |])   , ("may_str_b1" ,    [t| Maybe String |])   , ("str_b2" ,    [t| String |]) ]-  [] [0] $ Just 0)+  [''Generic] [0] $ Just 0)   $(defineTable defaultConfig "TEST" "set_c"@@ -30,19 +32,19 @@   , ("str_c1" ,    [t| String |])   , ("int_c2" ,    [t| Int64  |])   , ("may_str_c3" ,    [t| Maybe String |]) ]-  [] [0] $ Just 0)+  [''Generic] [0] $ Just 0)   $(defineTable defaultConfig "TEST" "set_i"   [ ("int_i0" ,    [t| Int32 |])  ]-  [] [0] $ Just 0)+  [''Generic] [0] $ Just 0)  data ABC =   ABC   { xJustA :: SetA   , xJustB :: SetB   , xJustC :: SetC-  }+  } deriving Generic  $(makeRelationalRecordDefault ''ABC) @@ -51,7 +53,7 @@   { yJustA :: SetA   , yMayB  :: Maybe SetB   , yMayC  :: Maybe SetC-  }+  } deriving Generic  $(makeRelationalRecordDefault ''Abc) 

@@ -1,10 +1,9 @@  import Test.QuickCheck.Simple (Test, defaultMain)-import qualified Test.QuickCheck.Simple as QSimple  import Control.Applicative ((<$>), (<*>)) -import Lex (eqProp, eqProp')+import Lex (eqProp) import Model  import Data.Int (Int32, Int64)@@ -78,31 +77,12 @@   intA0' <-# value (0 :: Int32)   return unitPlaceHolder -registerX :: Insert (String, Maybe String)+registerX :: Insert () registerX = derivedInsertValue $ do-  intC0' <-# value 1-  (ph1, ()) <- placeholder (\ph' -> strC1' <-# ph')-  intC2' <-# value 2-  (ph2, ()) <- placeholder (\ph' -> mayStrC3' <-# ph')-  return $ ph1 >< ph2--eqChunkedInsert :: String-                -> Insert a-                -> String-                -> String-                -> Test-eqChunkedInsert name ins prefix row =-    maybe-    (name, success)-    (\(sql, n) ->-      let estimate =-            unwords-            $ prefix-            : replicate (n - 1) (row ++ ",") ++ [row]-      in eqProp' name id sql estimate)-    $ chunkedInsert ins-  where-    success = QSimple.Bool Nothing True+  intA0' <-# value 1+  strA1' <-# value "Hello"+  strA2' <-# value "World"+  return unitPlaceHolder  monadic :: [Test] monadic =@@ -131,9 +111,7 @@   , eqProp "update"      assignX     "UPDATE TEST.set_a SET int_a0 = 0"   , eqProp "insert"      registerX-    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES (1, ?, 2, ?)"-  , eqChunkedInsert "insert chunked" registerX-    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES" "(1, ?, 2, ?)"+    "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (1, 'Hello', 'World')"   ]  _p_monadic :: IO ()@@ -330,63 +308,6 @@   , eqProp "div"   (bin53 (./.)) "SELECT ALL (5 / 3) AS f0"   ] -caseSearchX :: Relation () String-caseSearchX = relation $ do-  return $-    caseSearch-    [ (value 2 .=. value (1  :: Int32)            , value "foo")-    , (value 5 .=. value 3 .+. value (2 :: Int32) , value "bar")-    , (value "a" .=. value "b"                    , value "baz") ]-    (value "other")--caseX :: Relation () String-caseX = relation $ do-  return $-    case'-    (value (5 :: Int32))-    [ (value 1             , value "foo")-    , (value 3 .+. value 2 , value "bar")-    , (value 10            , value "baz") ]-    (value "other")--caseRecordX :: Relation () Int32-caseRecordX = relation $ do-  return $-    case'-    (value (5 :: Int32))-    [ (value 1             , (,) |$| value 1 |*| value "foo")-    , (value 3 .+. value 2 , (,) |$| value 2 |*| value "bar")-    , (value 10            , (,) |$| value 3 |*| value "baz") ]-    ((,) |$| value (0 :: Int32) |*| value "other")-    ! fst'-    .*.-    value 10--caseRecordMaybeX :: Relation () (Maybe (Int32, String))-caseRecordMaybeX = relation $ do-  return $-    caseMaybe-    (value (5 :: Int32))-    [ (value (1 :: Int32)  , just $ (,) |$| value (1 :: Int32) |*| value "foo")-    , (value 3 .+. value 2 , just $ (,) |$| value 2            |*| value "bar") ]--cases :: [Test]-cases =-  [ eqProp "caseSearch" caseSearchX-    "SELECT ALL CASE WHEN (2 = 1) THEN 'foo' WHEN (5 = (3 + 2)) THEN 'bar' WHEN ('a' = 'b') THEN 'baz' ELSE 'other' END AS f0"-  , eqProp "case"       caseX-    "SELECT ALL CASE 5 WHEN 1 THEN 'foo' WHEN (3 + 2) THEN 'bar' WHEN 10 THEN 'baz' ELSE 'other' END AS f0"-  , eqProp "caseRecord" caseRecordX-    "SELECT ALL (CASE 5 WHEN 1 THEN 1 WHEN (3 + 2) THEN 2 WHEN 10 THEN 3 ELSE 0 END * 10) AS f0"-  , eqProp "caseRecordMaybe" caseRecordMaybeX-    "SELECT ALL CASE 5 WHEN 1 THEN 1 WHEN (3 + 2) THEN 2 ELSE NULL END AS f0, \-              \ CASE 5 WHEN 1 THEN 'foo' WHEN (3 + 2) THEN 'bar' ELSE NULL END AS f1"-  ]--_p_cases :: IO ()-_p_cases =-  mapM_ print [show caseSearchX, show caseX]- nothingX :: Relation () (SetA, Maybe SetB) nothingX =  relation $ do   a <- query setA@@ -506,18 +427,7 @@   on $ just (a ! strA2') .=. b ?! strB2'    orderBy (a ! strA1') Asc-  orderBy' (b ?! mayStrB1') Desc NullsLast--  return $ (,) |$| a |*| b--ordFlatY :: Relation () (SetA, Maybe SetB)-ordFlatY =  relation $ do-  a <- query setA-  b <- queryMaybe setB-  on $ just (a ! strA2') .=. b ?! strB2'--  orderBy (a ! strA1') Asc-  orderBy' b Desc NullsLast+  orderBy (b ?! mayStrB1') Desc    return $ (,) |$| a |*| b @@ -527,7 +437,7 @@    gc1 <- groupBy $ c ! strC1' -  orderBy' (sum' $ c ! intC0') Asc NullsFirst+  orderBy (sum' $ c ! intC0') Asc    return $ gc1 >< count (c ! intC0') @@ -540,16 +450,10 @@     "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \     \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \     \  FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2) \-    \  ORDER BY T0.str_a1 ASC, T1.may_str_b1 DESC NULLS LAST"-  , eqProp "order-by - flag 2" ordFlatY-    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \-    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \-    \  FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2) \-    \  ORDER BY T0.str_a1 ASC, T1.int_b0 DESC NULLS LAST, \-    \           T1.may_str_b1 DESC NULLS LAST, T1.str_b2 DESC NULLS LAST"+    \  ORDER BY T0.str_a1 ASC, T1.may_str_b1 DESC"   , eqProp "order-by - aggregated" ordAggX     "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \-    \  FROM TEST.set_c T0 GROUP BY T0.str_c1 ORDER BY SUM(T0.int_c0) ASC NULLS FIRST"+    \  FROM TEST.set_c T0 GROUP BY T0.str_c1 ORDER BY SUM(T0.int_c0) ASC"   ]  partitionX :: Relation () (String, Int64)@@ -647,12 +551,8 @@ effs =   [ eqProp "insert" insertX     "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)"-  , eqChunkedInsert "insert chunked" insertX-    "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES" "(?, ?, ?)"   , eqProp "insert1" insertI     "INSERT INTO TEST.set_i (int_i0) VALUES (?)"-  , eqChunkedInsert "insert1 chunked" insertI-    "INSERT INTO TEST.set_i (int_i0) VALUES" "(?)"   , eqProp "insertQuery" insertQueryX     "INSERT INTO TEST.set_b (int_b0, str_b2, str_b2) SELECT int_a0, str_a1, str_a2 FROM TEST.set_a"   , eqProp "updateKey" updateKeyX@@ -730,7 +630,7 @@  tests :: [Test] tests =-  concat [ tables, monadic, directJoins, join3s, nested, bin, cases, uni+  concat [ tables, monadic, directJoins, join3s, nested, bin, uni          , groups, orders, partitions, exps, effs, correlated]  main :: IO ()

@@ -1,15 +1,39 @@ {-# LANGUAGE Arrows #-}  import Test.QuickCheck.Simple (Test, defaultMain)-import qualified Test.QuickCheck.Simple as QSimple -import Lex (eqProp, eqProp')+import Lex (eqProp) import Model  import Data.Int (Int32, Int64) import Control.Arrow (returnA, arr, (<<<), (***)) import Database.Relational.Query.Arrow +numBin :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r+numBin op = relation $ proc () -> do+  returnA -< value 5 `op` value 3++strConcat :: Relation () String+strConcat = relation $ proc () -> do+  returnA -< value "Hello, " .||. value "World!"++strLike :: Relation () (Maybe Bool)+strLike = relation $ proc () -> do+  returnA -< value "Hoge" `like` "H%"++_p_numBin :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO ()+_p_numBin = print . numBin++bin :: [Test]+bin =+  [ eqProp "plus"  (numBin (.+.)) "SELECT ALL (5 + 3) AS f0"+  , eqProp "minus" (numBin (.-.)) "SELECT ALL (5 - 3) AS f0"+  , eqProp "mult"  (numBin (.*.)) "SELECT ALL (5 * 3) AS f0"+  , eqProp "div"   (numBin (./.)) "SELECT ALL (5 / 3) AS f0"+  , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0"+  , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0"+  ]+ tables :: [Test] tables =   [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a"@@ -20,132 +44,6 @@ _p_tables :: IO () _p_tables =  mapM_ print [show setA, show setB, show setC] ---- Monadic Operators tests--queryX :: Relation () SetA-queryX = relation $ proc () -> do-  a <- query setA -< ()-  returnA -< a--queryMaybeX :: Relation () (Maybe SetA)-queryMaybeX = relation $ proc () -> do-  a <- queryMaybe setA -< ()-  returnA -< a--onX :: Relation () (Maybe SetA, SetB)-onX = relation $ proc () -> do-  a <- queryMaybe setA -< ()-  b <- query      setB -< ()-  on -< a ?! intA0' .=. just (b ! intB0')-  returnA -< (,) |$| a |*| b--wheresX :: Relation () (SetA, SetB)-wheresX = relation $ proc () -> do-  a <- query      setA -< ()-  b <- query      setB -< ()-  wheres -< b ! intB0' .>=. value 3-  returnA -< (,) |$| a |*| b--groupByX :: Relation () (Int32, Integer)-groupByX = aggregateRelation $ proc () -> do-  a <- query      setA -< ()-  ga0 <- groupBy -< a ! intA0'-  returnA -< (,) |$| ga0 |*| count (a ! intA0')--havingX :: Relation () Int-havingX = aggregateRelation $ proc () -> do-  a <- query      setA -< ()-  let c = count (a ! intA0')-  having -< c .>. value 1-  returnA -< c--distinctX :: Relation () Int32-distinctX = relation $ proc () -> do-  distinct -< ()-  a <- query      setA -< ()-  returnA -< a ! intA0'--all'X :: Relation () Int32-all'X = relation $ proc () -> do-  all' -< ()-  a <- query      setA -< ()-  returnA -< a ! intA0'--assignX :: Update ()-assignX = derivedUpdate $ proc _proj -> do-  assign intA0' -< value (0 :: Int32)-  returnA -< unitPlaceHolder--registerX :: Insert (String, Maybe String)-registerX = derivedInsertValue $ proc () -> do-  assign intC0' -< value 1-  (ph1, ()) <- placeholder -< proc ph' -> do assign strC1' -< ph'-  assign intC2' -< value 2-  (ph2, ()) <- placeholder -< proc ph' -> do assign mayStrC3' -< ph'-  returnA -< ph1 >< ph2--eqChunkedInsert :: String-                -> Insert a-                -> String-                -> String-                -> Test-eqChunkedInsert name ins prefix row =-    maybe-    (name, success)-    (\(sql, n) ->-      let estimate =-            unwords-            $ prefix-            : replicate (n - 1) (row ++ ",") ++ [row]-      in eqProp' name id sql estimate)-    $ chunkedInsert ins-  where-    success = QSimple.Bool Nothing True--monadic :: [Test]-monadic =-  [ eqProp "query"      queryX-    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2 FROM TEST.set_a T0"-  , eqProp "queryMaybe" queryMaybeX-    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2 FROM TEST.set_a T0"-  , eqProp "on"         onX-    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \-    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \-    \  FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)"-  , eqProp "wheres"     wheresX-    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \-    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \-    \  FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0) \-    \ WHERE (T1.int_b0 >= 3)"-  , eqProp "groupBy"    groupByX-    "SELECT ALL T0.int_a0 AS f0, COUNT(T0.int_a0) AS f1 \-    \  FROM TEST.set_a T0 GROUP BY T0.int_a0"-  , eqProp "having"     havingX-    "SELECT ALL COUNT(T0.int_a0) AS f0 FROM TEST.set_a T0 HAVING (COUNT(T0.int_a0) > 1)"-  , eqProp "distinct"   distinctX-    "SELECT DISTINCT T0.int_a0 AS f0 FROM TEST.set_a T0"-  , eqProp "all'"       all'X-    "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_c (int_c0, str_c1, int_c2, may_str_c3) VALUES (1, ?, 2, ?)"-  , eqChunkedInsert "insert chunked" registerX-    "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES" "(1, ?, 2, ?)"-  ]--_p_monadic :: IO ()-_p_monadic =-  mapM_ putStrLn-  [ show queryX, show queryMaybeX, show onX, show wheresX-  , show groupByX, show havingX, show distinctX, show all'X-  , show assignX-  ]----- Direct Join Operators- cross :: Relation () (SetA, SetB) cross =  setA `inner` setB `on'` [] @@ -277,55 +175,6 @@ _p_nested :: IO () _p_nested =  mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] ---- Projection Operators--bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r-bin53 op = relation $ proc () -> do-  returnA -< value 5 `op` value 3--strIn :: Relation () (Maybe Bool)-strIn = relation $ proc () -> do-  returnA -< value "foo" `in'` values ["foo", "bar"]--boolTF :: (Projection Flat (Maybe Bool) -> Projection Flat (Maybe Bool) -> Projection Flat r) -> Relation () r-boolTF op = relation $ proc () -> do-  returnA -< valueTrue `op` valueFalse--strConcat :: Relation () String-strConcat = relation $ proc () -> do-  returnA -< value "Hello, " .||. value "World!"--strLike :: Relation () (Maybe Bool)-strLike = relation $ proc () -> do-  returnA -< value "Hoge" `like` "H%"--_p_bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO ()-_p_bin53 = print . bin53--bin :: [Test]-bin =-  [ eqProp "equal" (bin53 (.=.))  "SELECT ALL (5 =  3) AS f0"-  , eqProp "lt"    (bin53 (.<.))  "SELECT ALL (5 <  3) AS f0"-  , eqProp "le"    (bin53 (.<=.)) "SELECT ALL (5 <= 3) AS f0"-  , eqProp "gt"    (bin53 (.>.))  "SELECT ALL (5 >  3) AS f0"-  , eqProp "ge"    (bin53 (.>=.)) "SELECT ALL (5 >= 3) AS f0"-  , eqProp "ne"    (bin53 (.<>.)) "SELECT ALL (5 <> 3) AS f0"--  , eqProp "and"   (boolTF and')  "SELECT ALL ((0=0) AND (0=1)) AS f0"-  , eqProp "or"    (boolTF or')   "SELECT ALL ((0=0) OR  (0=1)) AS f0"--  , eqProp "in"    strIn          "SELECT ALL ('foo' IN ('foo', 'bar')) AS f0"--  , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0"-  , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0"--  , eqProp "plus"  (bin53 (.+.)) "SELECT ALL (5 + 3) AS f0"-  , eqProp "minus" (bin53 (.-.)) "SELECT ALL (5 - 3) AS f0"-  , eqProp "mult"  (bin53 (.*.)) "SELECT ALL (5 * 3) AS f0"-  , eqProp "div"   (bin53 (./.)) "SELECT ALL (5 / 3) AS f0"-  ]- justX :: Relation () (SetA, Maybe SetB) justX =  relation $ proc () -> do   a <- query setA -< ()@@ -416,18 +265,7 @@   on -< just (a ! strA2') .=. b ?! strB2'    orderBy Asc  -< a ! strA1'-  orderBy' Desc NullsLast -< b ?! mayStrB1'--  returnA -< (,) |$| a |*| b--ordFlatY :: Relation () (SetA, Maybe SetB)-ordFlatY =  relation $ proc () -> do-  a <- query setA -< ()-  b <- queryMaybe setB -< ()-  on -< just (a ! strA2') .=. b ?! strB2'--  orderBy Asc  -< a ! strA1'-  orderBy' Desc NullsLast -< b+  orderBy Desc -< b ?! mayStrB1'    returnA -< (,) |$| a |*| b @@ -437,7 +275,7 @@    gc1 <- groupBy -< c ! strC1' -  orderBy' Asc NullsFirst -< sum' $ c ! intC0'+  orderBy Asc -< sum' $ c ! intC0'    returnA -< gc1 >< count (c ! intC0') @@ -450,16 +288,10 @@     "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \     \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \     \  FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2) \-    \  ORDER BY T0.str_a1 ASC, T1.may_str_b1 DESC NULLS LAST"-  , eqProp "order-by - flat 2" ordFlatY-    "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \-    \           T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \-    \  FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2) \-    \  ORDER BY T0.str_a1 ASC, T1.int_b0 DESC NULLS LAST, \-    \           T1.may_str_b1 DESC NULLS LAST, T1.str_b2 DESC NULLS LAST"+    \  ORDER BY T0.str_a1 ASC, T1.may_str_b1 DESC"   , eqProp "order-by - aggregated" ordAggX     "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \-    \  FROM TEST.set_c T0 GROUP BY T0.str_c1 ORDER BY SUM(T0.int_c0) ASC NULLS FIRST"+    \  FROM TEST.set_c T0 GROUP BY T0.str_c1 ORDER BY SUM(T0.int_c0) ASC"   ]  partitionX :: Relation () (String, Int64)@@ -571,7 +403,7 @@  tests :: [Test] tests =-  concat [ tables, monadic, directJoins, join3s, nested, bin, maybes+  concat [ bin, tables, directJoins, join3s, nested, maybes          , groups, orders, partitions, exps, effs]  main :: IO ()