relational-query 0.8.3.7 → 0.8.3.8

raw patch · 15 files changed

+203/−414 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• relational-query.cabal +1/−1
• src/Database/Relational/Query/Component.hs +2/−203
• src/Database/Relational/Query/Internal/BaseSQL.hs +7/−8
• src/Database/Relational/Query/Internal/GroupingSQL.hs +5/−8
• src/Database/Relational/Query/Internal/SQL.hs +0/−27
• src/Database/Relational/Query/Internal/Sub.hs +49/−3
• src/Database/Relational/Query/Internal/UntypedTable.hs +5/−5
• src/Database/Relational/Query/Monad/Aggregate.hs +1/−2
• src/Database/Relational/Query/Projectable.hs +27/−38
• src/Database/Relational/Query/Projection.hs +4/−6
• src/Database/Relational/Query/SQL.hs +6/−7
• src/Database/Relational/Query/Sub.hs +33/−73
• src/Database/Relational/Query/Table.hs +8/−32
• test/sqlsEq.hs +47/−1

@@ -1,5 +1,13 @@ <!-- -*- Markdown -*- --> +## 0.8.3.8++- Bugfix of case projected record. ( https://github.com/khibino/haskell-relational-record/issues/54 )++## 0.8.3.7++- Add version constraint for LTS-8.+ ## 0.8.3.6  - Bugfix of lazy instances of ShowConstantTermsSQL.

@@ -1,5 +1,5 @@ name:                relational-query-version:             0.8.3.7+version:             0.8.3.8 synopsis:            Typeful, Modular, Relational, algebraic query engine description:         This package contiains typeful relation structure and                      relational-algebraic query building DSL which can

@@ -1,6 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}- -- | -- Module      : Database.Relational.Query.Component -- Copyright   : 2013-2017 Kei Hibino@@ -12,217 +9,19 @@ -- -- This module provides untyped components for query. module Database.Relational.Query.Component-       ( -- * Type for column SQL string--         -- deprecated interfaces-         ColumnSQL, columnSQL, columnSQL', showsColumnSQL,--         -- * Configuration type for query+       ( -- * Configuration type for query          module Database.Relational.Query.Internal.Config, -         -- * Duplication attribute-         -- deprecated interfaces - import Duplication from internal module-         Duplication (..), showsDuplication,-          -- * Types for aggregation          AggregateKey, -         -- deprecated interfaces-         AggregateColumnRef,-         AggregateBitKey, AggregateSet, AggregateElem,-         aggregateColumnRef, aggregateEmpty,-         aggregatePowerKey, aggregateGroupingSet,-         aggregateRollup, aggregateCube, aggregateSets,-         composeGroupBy, composePartitionBy,-         aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey,-          -- * Types for ordering          Order (..),--         -- deprecated interfaces-         OrderColumn, OrderingTerm, composeOrderBy,--         -- deprecated interfaces-         OrderingTerms,--         -- * Types for assignments-         -- deprecated interfaces-         AssignColumn, AssignTerm, Assignment, composeSets, composeValues,--         -- deprecated interfaces-         Assignments,--         -- * Compose window clause-         composeOver,        ) where -import Data.Monoid ((<>))--import Language.SQL.Keyword (Keyword(..))-import qualified Language.SQL.Keyword as SQL- import Database.Relational.Query.Internal.Config   (NameConfig (..),    ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..),    Config (..), defaultConfig,)-import Database.Relational.Query.Internal.SQL (StringSQL)-import qualified Database.Relational.Query.Internal.SQL as Internal-import Database.Relational.Query.Internal.BaseSQL-  (Duplication (..), Order (..),)-import qualified Database.Relational.Query.Internal.BaseSQL as BaseSQL+import Database.Relational.Query.Internal.BaseSQL (Order (..),) import Database.Relational.Query.Internal.GroupingSQL (AggregateKey)-import qualified Database.Relational.Query.Internal.GroupingSQL as GroupingSQL---{-# DEPRECATED-  ColumnSQL,-  columnSQL, columnSQL', showsColumnSQL-  "prepare to drop public interface. internally use Database.Relational.Query.Internal.SQL.*" #-}--- | Column SQL string type-type ColumnSQL = Internal.ColumnSQL---- | 'ColumnSQL' from string-columnSQL :: String -> ColumnSQL-columnSQL = Internal.columnSQL---- | 'ColumnSQL' from 'StringSQL'-columnSQL' :: StringSQL -> ColumnSQL-columnSQL' = Internal.columnSQL'---- | StringSQL from ColumnSQL-showsColumnSQL :: ColumnSQL -> StringSQL-showsColumnSQL = Internal.showsColumnSQL---{-# DEPRECATED-    showsDuplication-    "prepare to drop public interface. internally use Database.Relational.Query.Internal.BaseSQL.showsDuplication" #-}--- | Compose duplication attribute string.-showsDuplication :: Duplication -> StringSQL-showsDuplication = BaseSQL.showsDuplication---{-# DEPRECATED-  AggregateColumnRef,-  AggregateBitKey, AggregateSet, AggregateElem,--  aggregateColumnRef, aggregateEmpty,-  aggregatePowerKey, aggregateGroupingSet,-  aggregateRollup, aggregateCube, aggregateSets,--  composeGroupBy, composePartitionBy,--  aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey--  "prepare to drop public interface. internally use Database.Relational.Query.Internal.GroupingSQL.*" #-}--- | Type for group-by term-type AggregateColumnRef = GroupingSQL.AggregateColumnRef---- | Type for group key.-type AggregateBitKey = GroupingSQL.AggregateBitKey---- | Type for grouping set-type AggregateSet = GroupingSQL.AggregateSet---- | Type for group-by tree-type AggregateElem = GroupingSQL.AggregateElem---- | Single term aggregation element.-aggregateColumnRef :: AggregateColumnRef -> AggregateElem-aggregateColumnRef = GroupingSQL.aggregateColumnRef---- | Key of aggregation power set.-aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey-aggregatePowerKey = GroupingSQL.aggregatePowerKey---- | Single grouping set.-aggregateGroupingSet :: [AggregateElem] -> AggregateSet-aggregateGroupingSet = GroupingSQL.aggregateGroupingSet---- | Rollup aggregation element.-aggregateRollup :: [AggregateBitKey] -> AggregateElem-aggregateRollup = GroupingSQL.aggregateRollup---- | Cube aggregation element.-aggregateCube :: [AggregateBitKey] -> AggregateElem-aggregateCube = GroupingSQL.aggregateCube---- | Grouping sets aggregation.-aggregateSets :: [AggregateSet] -> AggregateElem-aggregateSets = GroupingSQL.aggregateSets---- | Empty aggregation.-aggregateEmpty :: [AggregateElem]-aggregateEmpty = GroupingSQL.aggregateEmpty---- | Compose GROUP BY clause from AggregateElem list.-composeGroupBy :: [AggregateElem] -> StringSQL-composeGroupBy = GroupingSQL.composeGroupBy---- | Compose PARTITION BY clause from AggregateColumnRef list.-composePartitionBy :: [AggregateColumnRef] -> StringSQL-composePartitionBy = GroupingSQL.composePartitionBy---- | Extract typed projection from 'AggregateKey'.-aggregateKeyProjection :: AggregateKey a -> a-aggregateKeyProjection = GroupingSQL.aggregateKeyProjection---- | Extract untyped term from 'AggregateKey'.-aggregateKeyElement :: AggregateKey a -> AggregateElem-aggregateKeyElement = GroupingSQL.aggregateKeyElement---- | Unsafely bind typed-projection and untyped-term into 'AggregateKey'.-unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a-unsafeAggregateKey = GroupingSQL.unsafeAggregateKey---{-# DEPRECATED OrderingTerms "use [OrderingTerm]." #-}--- | Type for order-by terms-type OrderingTerms = [OrderingTerm]--{-# DEPRECATED-   OrderColumn, OrderingTerm,-   composeOrderBy-   "prepare to drop public interface. internally use Database.Relational.Query.Internal.BaseSQL.*" #-}--- | Type for order-by column-type OrderColumn = BaseSQL.OrderColumn---- | Type for order-by term-type OrderingTerm = BaseSQL.OrderingTerm---- | Compose ORDER BY clause from OrderingTerms-composeOrderBy :: [OrderingTerm] -> StringSQL-composeOrderBy = BaseSQL.composeOrderBy---{-# DEPRECATED Assignments "use [Assignment]." #-}--- | Assignment pair list.-type Assignments = [Assignment]--{-# DEPRECATED-   AssignColumn, AssignTerm, Assignment,-   composeSets, composeValues-   "prepare to drop public interface. internally use Database.Relational.Query.Internal.BaseSQL.*" #-}--- | Column SQL String of assignment-type AssignColumn = BaseSQL.AssignColumn---- | Value SQL String of assignment-type AssignTerm   = BaseSQL.AssignTerm---- | Assignment pair-type Assignment = BaseSQL.Assignment---- | Compose SET clause from ['Assignment'].-composeSets :: [Assignment] -> StringSQL-composeSets = BaseSQL.composeSets---- | Compose VALUES clause from ['Assignment'].-composeValues :: [Assignment] -> StringSQL-composeValues = BaseSQL.composeValues---{-# DEPRECATED composeOver "prepare to drop public interface." #-}--- | Compose /OVER (PARTITION BY ... )/ clause.-composeOver :: [AggregateColumnRef] -> OrderingTerms -> StringSQL-composeOver pts ots =-  OVER <> SQL.paren (composePartitionBy pts <> composeOrderBy ots)

@@ -20,7 +20,7 @@ import qualified Language.SQL.Keyword as SQL  import Database.Relational.Query.Internal.SQL-  (StringSQL, rowConsStringSQL, ColumnSQL, showsColumnSQL)+  (StringSQL, rowConsStringSQL)   -- | Result record duplication attribute@@ -37,7 +37,7 @@ data Order = Asc | Desc  deriving Show  -- | Type for order-by column-type OrderColumn = ColumnSQL+type OrderColumn = StringSQL  -- | Type for order-by term type OrderingTerm = (Order, OrderColumn)@@ -47,16 +47,16 @@ composeOrderBy =  d where   d []       = mempty   d ts@(_:_) = ORDER <> BY <> SQL.fold (|*|) (map showsOt ts)-  showsOt (o, e) = showsColumnSQL e <> order o+  showsOt (o, e) = e <> order o   order Asc  = ASC   order Desc = DESC   -- | Column SQL String of assignment-type AssignColumn = ColumnSQL+type AssignColumn = StringSQL  -- | Value SQL String of assignment-type AssignTerm   = ColumnSQL+type AssignTerm   = StringSQL  -- | Assignment pair type Assignment = (AssignColumn, AssignTerm)@@ -65,13 +65,12 @@ composeSets :: [Assignment] -> StringSQL composeSets as = assigns  where   assignList = foldr (\ (col, term) r ->-                       (showsColumnSQL col .=. showsColumnSQL term) : r)+                       (col .=. term) : r)                [] as   assigns | null assignList = error "Update assignment list is null!"           | otherwise       = SET <> SQL.fold (|*|) assignList  -- | Compose VALUES clause from ['Assignment']. composeValues :: [Assignment] -> StringSQL-composeValues as = rowConsStringSQL [ showsColumnSQL c | c <- cs ] <> VALUES <>-                   rowConsStringSQL [ showsColumnSQL c | c <- vs ]  where+composeValues as = rowConsStringSQL cs <> VALUES <> rowConsStringSQL vs  where   (cs, vs) = unzip as

@@ -28,11 +28,11 @@ import Language.SQL.Keyword (Keyword(..), (|*|)) import qualified Language.SQL.Keyword as SQL -import Database.Relational.Query.Internal.SQL (StringSQL, ColumnSQL, showsColumnSQL)+import Database.Relational.Query.Internal.SQL (StringSQL)   -- | Type for group-by term-type AggregateColumnRef = ColumnSQL+type AggregateColumnRef = StringSQL  -- | Type for group key. newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show@@ -78,9 +78,6 @@ aggregateEmpty :: [AggregateElem] aggregateEmpty =  [] -showsAggregateColumnRef :: AggregateColumnRef -> StringSQL-showsAggregateColumnRef =  showsColumnSQL- commaed :: [StringSQL] -> StringSQL commaed =  SQL.fold (|*|) @@ -88,7 +85,7 @@ pComma qshow =  SQL.paren . commaed . map qshow  showsAggregateBitKey :: AggregateBitKey -> StringSQL-showsAggregateBitKey (AggregateBitKey ts) = pComma showsAggregateColumnRef ts+showsAggregateBitKey (AggregateBitKey ts) = pComma id ts  -- | Compose GROUP BY clause from AggregateElem list. composeGroupBy :: [AggregateElem] -> StringSQL@@ -98,7 +95,7 @@   keyList op ss = op <> pComma showsAggregateBitKey ss   rec = commaed . map showsE   showsGs (AggregateSet s) = SQL.paren $ rec s-  showsE (ColumnRef t)     = showsAggregateColumnRef t+  showsE (ColumnRef t)     = t   showsE (Rollup ss)       = keyList ROLLUP ss   showsE (Cube   ss)       = keyList CUBE   ss   showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss@@ -107,7 +104,7 @@ composePartitionBy :: [AggregateColumnRef] -> StringSQL composePartitionBy =  d where   d []       = mempty-  d ts@(_:_) = PARTITION <> BY <> commaed (map showsAggregateColumnRef ts)+  d ts@(_:_) = PARTITION <> BY <> commaed ts  -- | Extract typed projection from 'AggregateKey'. aggregateKeyProjection :: AggregateKey a -> a

@@ -16,8 +16,6 @@   rowStringSQL, rowPlaceHolderStringSQL,    rowConsStringSQL, listStringSQL,--  ColumnSQL, columnSQL, columnSQL', showsColumnSQL,   ) where  import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren)@@ -52,28 +50,3 @@ -- | List String of SQL. listStringSQL :: [StringSQL] -> StringSQL listStringSQL =  paren . fold (|*|)----- | Simple wrap type-newtype ColumnSQL' a = ColumnSQL a--instance Functor ColumnSQL' where-  fmap f (ColumnSQL c) = ColumnSQL $ f c---- | Column SQL string type-type ColumnSQL = ColumnSQL' StringSQL---- | 'ColumnSQL' from string-columnSQL :: String -> ColumnSQL-columnSQL =  columnSQL' . stringSQL---- | 'ColumnSQL' from 'StringSQL'-columnSQL' :: StringSQL -> ColumnSQL-columnSQL' =  ColumnSQL---- | StringSQL from ColumnSQL-showsColumnSQL :: ColumnSQL -> StringSQL-showsColumnSQL (ColumnSQL c) = c--instance Show ColumnSQL where-  show = showStringSQL . showsColumnSQL

@@ -21,6 +21,9 @@        , JoinProduct, QueryProductTree        , ProductTreeBuilder, ProductBuilder +       , CaseClause (..), WhenClauses(..)+       , caseSearch, case'+        , UntypedProjection, untypedProjectionWidth, ProjectionUnit (..)        , Projection, untypeProjection, typedProjection, projectionWidth        , projectFromColumns, projectFromScalarSubQuery@@ -36,7 +39,7 @@  import Database.Relational.Query.Internal.Config (Config) import Database.Relational.Query.Internal.ContextType (Flat, Aggregated)-import Database.Relational.Query.Internal.SQL (ColumnSQL)+import Database.Relational.Query.Internal.SQL (StringSQL) import Database.Relational.Query.Internal.BaseSQL (Duplication (..), OrderingTerm) import Database.Relational.Query.Internal.GroupingSQL (AggregateElem) import Database.Relational.Query.Internal.UntypedTable (Untyped)@@ -116,12 +119,23 @@ -- | 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 ColumnSQL            -- ^ used in immediate value or unsafe operations+  = 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.@@ -145,13 +159,45 @@ projectionWidth = length . untypeProjection  -- | Unsafely generate 'Projection' from SQL string list.-projectFromColumns :: [ColumnSQL]    -- ^ SQL string list specifies columns+projectFromColumns :: [StringSQL]    -- ^ SQL string list specifies columns                    -> Projection c r -- ^ Result 'Projection' projectFromColumns =  typedProjection . map RawColumn  -- | Unsafely generate 'Projection' from scalar sub-query. projectFromScalarSubQuery :: SubQuery -> Projection c t projectFromScalarSubQuery = typedProjection . (:[]) . Scalar++whenClauses :: String                             -- ^ Error tag+            -> [(Projection c a, Projection c b)] -- ^ Each when clauses+            -> Projection c b                     -- ^ Else result projection+            -> WhenClauses                        -- ^ Result clause+whenClauses eTag ws0 e = d ws0+  where+    d []       = error $ eTag ++ ": Empty when clauses!"+    d ws@(_:_) =+      WhenClauses [ (untypeProjection p, untypeProjection r) | (p, r) <- ws ]+      $ untypeProjection e++-- | Search case operator correnponding SQL search /CASE/.+--   Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/+caseSearch :: [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses+           -> Projection c a                                -- ^ Else result projection+           -> Projection c a                                -- ^ Result projection+caseSearch ws e =+    typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ]+  where+    c = CaseSearch $ whenClauses "caseSearch" ws e++-- | Simple case operator correnponding SQL simple /CASE/.+--   Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/+case' :: Projection c a                     -- ^ Projection value to match+      -> [(Projection c a, Projection c b)] -- ^ Each when clauses+      -> Projection c b                     -- ^ Else result projection+      -> Projection c b                     -- ^ Result projection+case' v ws e =+    typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ]+  where+    c = CaseSimple (untypeProjection v) $ whenClauses "case'" ws e   -- | Type for restriction of query.

@@ -15,11 +15,11 @@ import Data.Array (Array, elems) import qualified Data.Array as Array -import Database.Relational.Query.Internal.SQL (ColumnSQL)+import Database.Relational.Query.Internal.SQL (StringSQL)   -- | Untyped typed table type-data Untyped = Untyped String Int (Array Int ColumnSQL)  deriving Show+data Untyped = Untyped String Int (Array Int StringSQL)  deriving Show  -- | Name string of table in SQL name' :: Untyped -> String@@ -30,15 +30,15 @@ width'      (Untyped _ w _) = w  -- | Column name strings in SQL-columnArray :: Untyped -> Array Int ColumnSQL+columnArray :: Untyped -> Array Int StringSQL columnArray (Untyped _ _ c) = c  -- | Column name strings in SQL-columns' :: Untyped -> [ColumnSQL]+columns' :: Untyped -> [StringSQL] columns' =  elems . columnArray  -- | Column name string in SQL specified by index (!) :: Untyped     -> Int       -- ^ Column index-    -> ColumnSQL -- ^ Column name String in SQL+    -> StringSQL -- ^ Column name String in SQL t ! i = columnArray t Array.! i

@@ -32,7 +32,6 @@ import Language.SQL.Keyword (Keyword(..)) import qualified Language.SQL.Keyword as SQL -import Database.Relational.Query.Internal.SQL (showsColumnSQL) import Database.Relational.Query.Internal.BaseSQL (Duplication, OrderingTerm, composeOrderBy) import Database.Relational.Query.Internal.GroupingSQL (AggregateColumnRef, AggregateElem, composePartitionBy) @@ -97,7 +96,7 @@      -> Projection c a wp `over` win =   Projection.unsafeFromSqlTerms-  [ showsColumnSQL c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot)+  [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot)   | c <- Projection.columns wp   ]  where (((), ot), pt) = extractWindow win 

@@ -67,7 +67,6 @@ import Prelude hiding (pi)  import Data.String (IsString)-import Data.Monoid ((<>), mconcat) import Control.Applicative ((<$>))  import Language.SQL.Keyword (Keyword)@@ -78,6 +77,7 @@    HasColumnConstraint, NotNull)  import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)+import qualified Database.Relational.Query.Internal.Sub as Internal  import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow) import Database.Relational.Query.Pure@@ -360,59 +360,48 @@                    => 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 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+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  -- | Same as 'caseSearch', but you can write like <when list> `casesOrElse` <else clause>.-casesOrElse :: (OperatorProjectable p, ProjectableShowSql p)-            => [(p (Maybe Bool), p a)] -- ^ Each when clauses-            -> p a                     -- ^ Else result projection-            -> p a                     -- ^ Result projection+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 = caseSearch  -- | Null default version of 'caseSearch'.-caseSearchMaybe :: (OperatorProjectable p, ProjectableShowSql p)-                => [(p (Maybe Bool), p (Maybe a))] -- ^ Each when clauses-                -> p (Maybe a)                     -- ^ Result projection+caseSearchMaybe :: OperatorProjectable (Projection c) -- (Projection c) is always ProjectableMaybe+                => [(Projection c (Maybe Bool), Projection c (Maybe a))] -- ^ Each when clauses+                -> Projection c (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 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+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'  -- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` <else clause>.-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' :: 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' =  uncurry case'  -- | Null default version of 'case''.-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 :: OperatorProjectable (Projection c) -- (Projection c) is always ProjectableMaybe+          => Projection c a                             -- ^ Projection value to match+          -> [(Projection c a, Projection c (Maybe b))] -- ^ Each when clauses+          -> Projection c (Maybe b)                     -- ^ Result projection caseMaybe v cs = case' v cs unsafeValueNull  -- | Binary operator corresponding SQL /IN/ .

@@ -47,9 +47,7 @@ import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint) import qualified Database.Record.KeyConstraint as KeyConstraint -import Database.Relational.Query.Internal.SQL-  (StringSQL, listStringSQL,-   ColumnSQL, showsColumnSQL, columnSQL', )+import Database.Relational.Query.Internal.SQL (StringSQL, listStringSQL, ) import Database.Relational.Query.Internal.Sub   (SubQuery, Qualified, UntypedProjection,    Projection, untypeProjection, typedProjection, projectionWidth)@@ -74,7 +72,7 @@  -- | Get column SQL string list of projection. columns :: Projection c r -- ^ Source 'Projection'-        -> [ColumnSQL]    -- ^ Result SQL string list+        -> [StringSQL]    -- ^ Result SQL string list columns = projectionColumns  -- | Width of 'Projection'.@@ -101,7 +99,7 @@  -- | Unsafely generate 'Projection' from SQL expression strings. unsafeFromSqlTerms :: [StringSQL] -> Projection c t-unsafeFromSqlTerms = Internal.projectFromColumns . map columnSQL'+unsafeFromSqlTerms = Internal.projectFromColumns   -- | Unsafely trace projection path.@@ -158,7 +156,7 @@  -- | Unsafely get SQL string expression of not null key projection. unsafeStringSqlNotNullMaybe :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> StringSQL-unsafeStringSqlNotNullMaybe p = showsColumnSQL . (!!  KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p+unsafeStringSqlNotNullMaybe p = (!!  KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p  -- | Projectable fmap of 'Projection' type. pfmap :: ProductConstructor (a -> b)

@@ -34,8 +34,7 @@ import Database.Record.ToSql (untypedUpdateValuesIndex)  import Database.Relational.Query.Internal.SQL-  (StringSQL, stringSQL, showStringSQL, rowConsStringSQL,-   ColumnSQL, showsColumnSQL, showsColumnSQL, )+  (StringSQL, stringSQL, showStringSQL, rowConsStringSQL, )  import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi@@ -57,22 +56,22 @@ -- | Generate update SQL by specified key and table. --   Columns name list of table are also required. updateSQL' :: String      -- ^ Table name-           -> [ColumnSQL] -- ^ Column name list to update-           -> [ColumnSQL] -- ^ Key column name list+           -> [StringSQL] -- ^ Column name list to update+           -> [StringSQL] -- ^ Key column name list            -> String      -- ^ Result SQL updateSQL' table cols key =   showStringSQL $ mconcat   [UPDATE, stringSQL table, SET, SQL.fold (|*|) updAssigns,    WHERE, SQL.fold SQL.and keyAssigns]   where-    assigns cs = [ showsColumnSQL c .=. "?" | c <- cs ]+    assigns cs = [ c .=. "?" | c <- cs ]     updAssigns = assigns cols     keyAssigns = assigns key  -- | Generate update SQL by specified key and table. --   Columns name list of table are also required. updateOtherThanKeySQL' :: String      -- ^ Table name-                       -> [ColumnSQL] -- ^ Column name list+                       -> [StringSQL] -- ^ Column name list                        -> [Int]       -- ^ Key column indexes                        -> String      -- ^ Result SQL updateOtherThanKeySQL' table cols ixs =@@ -95,7 +94,7 @@ -- | Generate prefix string of insert SQL. insertPrefixSQL :: Pi r r' -> Table r -> StringSQL insertPrefixSQL pi' table =-  INSERT <> INTO <> stringSQL (name table) <> rowConsStringSQL [showsColumnSQL c | c <- cols]  where+  INSERT <> INTO <> stringSQL (name table) <> rowConsStringSQL cols  where     cols = Projection.columns . Projection.pi (Projection.unsafeFromTable table) $ pi'  -- | Generate records chunk insert SQL.

@@ -21,9 +21,6 @@   Qualified,   queryWidth, -  -- deprecated interfaces-  qualifier, unQualify, qualify,-   -- * Sub-query columns   column, @@ -34,14 +31,8 @@    projectionColumns, unsafeProjectionStringSql, -  -- deprecated interfaces-  untypedProjectionFromColumns, untypedProjectionFromScalarSubQuery,-  unsafeProjectFromColumns,-  widthOfUntypedProjection, columnsOfUntypedProjection,-   -- * Product of sub-queries   JoinProduct, NodeAttr (..),-  nodeTree,   ProductBuilder,    -- * Query restriction@@ -60,17 +51,17 @@   (Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported)) import qualified Database.Relational.Query.Context as Context import Database.Relational.Query.Internal.SQL-  (StringSQL, stringSQL, rowStringSQL, showStringSQL,-   ColumnSQL, columnSQL', showsColumnSQL, )+  (StringSQL, stringSQL, rowStringSQL, showStringSQL, ) import Database.Relational.Query.Internal.BaseSQL   (Duplication (..), showsDuplication, OrderingTerm, composeOrderBy, ) import Database.Relational.Query.Internal.GroupingSQL   (AggregateElem, composeGroupBy, ) import Database.Relational.Query.Internal.Sub   (SubQuery (..), Projection,+   CaseClause(..), WhenClauses (..),    UntypedProjection, ProjectionUnit (..),    JoinProduct, QueryProductTree, ProductBuilder,-   NodeAttr (Just', Maybe), ProductTree (Leaf, Join), Node,+   NodeAttr (Just', Maybe), ProductTree (Leaf, Join),    SetOp (..), BinOp (..), Qualifier (..), Qualified (..),    QueryRestriction) import qualified Database.Relational.Query.Internal.Sub as Internal@@ -146,7 +137,7 @@ -- | SQL to query table. fromTableToSQL :: UntypedTable.Untyped -> StringSQL fromTableToSQL t =-  SELECT <> SQL.fold (|*|) [showsColumnSQL c | c <- UntypedTable.columns' t] <>+  SELECT <> SQL.fold (|*|) (UntypedTable.columns' t) <>   FROM <> stringSQL (UntypedTable.name' t)  -- | Generate normalized column SQL from table.@@ -205,38 +196,23 @@ toSQL :: SubQuery -> String toSQL =  showStringSQL . showSQL -{-# DEPRECATED qualifier "prepare to drop public interface. use Database.Relational.Query.Internal.Sub.qualifier." #-}--- | Get qualifier-qualifier :: Qualified a -> Qualifier-qualifier = Internal.qualifier--{-# DEPRECATED unQualify "prepare to drop public interface. use Database.Relational.Query.Internal.Sub.unQualify." #-}--- | Unqualify.-unQualify :: Qualified a -> a-unQualify = Internal.unQualify--{-# DEPRECATED qualify "prepare to drop public interface. use Database.Relational.Query.Internal.Sub.qualify." #-}--- | Add qualifier-qualify :: a -> Qualifier -> Qualified a-qualify a q = Internal.qualify q a- columnN :: Int -> StringSQL columnN i = stringSQL $ 'f' : show i -asColumnN :: ColumnSQL -> Int -> StringSQL-c `asColumnN` n = showsColumnSQL c `SQL.as` columnN n+asColumnN :: StringSQL -> Int -> StringSQL+c `asColumnN` n =c `SQL.as` columnN n  -- | Alias string from qualifier showQualifier :: Qualifier -> StringSQL showQualifier (Qualifier i) = stringSQL $ 'T' : show i  -- | Binary operator to qualify.-(<.>) :: Qualifier -> ColumnSQL -> ColumnSQL-i <.> n = (showQualifier i SQL.<.>) <$> n+(<.>) :: Qualifier -> StringSQL -> StringSQL+i <.> n = showQualifier i SQL.<.> n  -- | Qualified expression from qualifier and projection index.-columnFromId :: Qualifier -> Int -> ColumnSQL-columnFromId qi i = qi <.> columnSQL' (columnN i)+columnFromId :: Qualifier -> Int -> StringSQL+columnFromId qi i = qi <.> columnN i  -- | From 'Qualified' SQL string into qualified formed 'String' --  like (SELECT ...) AS T<n>@@ -248,7 +224,7 @@ queryWidth =  width . Internal.unQualify  -- | Get column SQL string of 'SubQuery'.-column :: Qualified SubQuery -> Int -> ColumnSQL+column :: Qualified SubQuery -> Int -> StringSQL column qs =  d (Internal.unQualify qs)  where   q = Internal.qualifier qs   d (Table u)           i           = q <.> (u ! i)@@ -257,16 +233,6 @@   d (Aggregated _ up _ _ _ _ _ _) i = columnOfUntypedProjection up i  -{-# DEPRECATED untypedProjectionFromColumns "prepare to drop public interface. use (map RawColumn)." #-}--- | Make untyped projection from columns.-untypedProjectionFromColumns :: [ColumnSQL] -> UntypedProjection-untypedProjectionFromColumns =  map RawColumn--{-# DEPRECATED untypedProjectionFromScalarSubQuery "prepare to drop public interface. use ( (:[]) . Scalar )." #-}--- | Make untyped projection from scalar sub-query.-untypedProjectionFromScalarSubQuery :: SubQuery -> UntypedProjection-untypedProjectionFromScalarSubQuery = (:[]) . Scalar- -- | Make untyped projection from joined sub-query. untypedProjectionFromJoinedSubQuery :: Qualified SubQuery -> UntypedProjection untypedProjectionFromJoinedSubQuery qs = d $ Internal.unQualify qs  where@@ -277,55 +243,49 @@   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 -> ColumnSQL+columnOfProjectionUnit :: ProjectionUnit -> StringSQL columnOfProjectionUnit = d  where   d (RawColumn e)     = e   d (SubQueryRef qi)  = Internal.qualifier qi `columnFromId` Internal.unQualify qi-  d (Scalar sub)      = columnSQL' $ showUnitSQL sub--{-# DEPRECATED widthOfUntypedProjection "prepare to drop public interface. use untypedProjectionWidth internally." #-}--- | Width of 'UntypedProjection'.-widthOfUntypedProjection :: UntypedProjection -> Int-widthOfUntypedProjection = Internal.untypedProjectionWidth+  d (Scalar sub)      = showUnitSQL sub+  d (Case c i)        = caseClause c i  -- | Get column SQL string of 'UntypedProjection'. columnOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection'                           -> Int               -- ^ Column index-                          -> ColumnSQL         -- ^ Result SQL string+                          -> StringSQL         -- ^ Result SQL string columnOfUntypedProjection up i   | 0 <= i && i < Internal.untypedProjectionWidth up  =     columnOfProjectionUnit $ up !! i   | otherwise                                         =     error $ "columnOfUntypedProjection: index out of bounds: " ++ show i -{-# DEPRECATED columnsOfUntypedProjection "prepare to drop unused interface." #-} -- | Get column SQL string list of projection.-columnsOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection'-                           -> [ColumnSQL]       -- ^ Result SQL string list-columnsOfUntypedProjection = map columnOfProjectionUnit---- | Get column SQL string list of projection. projectionColumns :: Projection c r -- ^ Source 'Projection'-                  -> [ColumnSQL]    -- ^ Result SQL string list+                  -> [StringSQL]    -- ^ Result SQL string list projectionColumns = map columnOfProjectionUnit . Internal.untypeProjection  -- | Unsafely get SQL term from 'Proejction'. unsafeProjectionStringSql :: Projection c r -> StringSQL-unsafeProjectionStringSql =  rowStringSQL . map showsColumnSQL . projectionColumns--{-# DEPRECATED unsafeProjectFromColumns "prepare to drop unused interface. use Database.Relational.Query.Internal.Sub.projectFromColumns. " #-}--- | Unsafely generate 'Projection' from SQL string list.-unsafeProjectFromColumns :: [ColumnSQL]    -- ^ SQL string list specifies columns-                         -> Projection c r -- ^ Result 'Projection'-unsafeProjectFromColumns = Internal.projectFromColumns+unsafeProjectionStringSql =  rowStringSQL . projectionColumns  -{-# DEPRECATED nodeTree "prepare to drop unused interface. use Database.Relational.Query.Internal.Sub.nodeTree. " #-}--- | Get tree from node.-nodeTree :: Node rs -> ProductTree rs-nodeTree = Internal.nodeTree- -- | Show product tree of query into SQL. StringSQL result. showsQueryProduct :: QueryProductTree -> StringSQL showsQueryProduct =  rec  where@@ -333,7 +293,7 @@   joinType Just' Maybe = LEFT   joinType Maybe Just' = RIGHT   joinType Maybe Maybe = FULL-  urec n = case nodeTree n of+  urec n = case Internal.nodeTree n of     p@(Leaf _)     -> rec p     p@(Join {})    -> SQL.paren (rec p)   rec (Leaf q)               = qualifiedSQLas $ fmap showUnitSQL q

@@ -9,10 +9,6 @@ -- -- This module defines table type which has table metadatas. module Database.Relational.Query.Table (-  -- * Untyped table type-  -- deprecated interfaces-  Untyped, name', width', columns', (!),-   -- * Phantom typed table type   Table, unType, name, shortName, width, columns, index, table, toMaybe, @@ -24,30 +20,10 @@  import Database.Record (PersistableWidth) -import qualified Database.Relational.Query.Internal.UntypedTable as Untyped-import Database.Relational.Query.Internal.SQL (ColumnSQL, columnSQL)+import Database.Relational.Query.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!))+import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, )  -{-# DEPRECATED Untyped, name', width', columns', (!) "prepare to drop public interface. internally use Database.Relational.Query.Internal.UntypedTable.*" #-}--- | Untyped typed table type-type Untyped = Untyped.Untyped---- | Name string of table in SQL-name' :: Untyped -> String-name' = Untyped.name'---- | Width of table-width' :: Untyped -> Int-width' = Untyped.width'---- | Column name strings in SQL-columns' :: Untyped -> [ColumnSQL]-columns' = Untyped.columns'---- | Column name strings in SQL-(!) :: Untyped -> Int -> ColumnSQL-(!) = (Untyped.!)- -- | Phantom typed table type newtype Table r = Table Untyped @@ -57,7 +33,7 @@  -- | Name string of table in SQL name :: Table r -> String-name   = name'   . unType+name   = name' . unType  -- | Not qualified name string of table in SQL shortName :: Table r -> String@@ -65,16 +41,16 @@  -- | Width of table width :: Table r -> Int-width  = width'  . unType+width  = width' . unType  -- | Column name strings in SQL-columns :: Table r -> [ColumnSQL]+columns :: Table r -> [StringSQL] columns =  columns' . unType  -- | Column name string in SQL specified by index index :: Table r       -> Int       -- ^ Column index-      -> ColumnSQL -- ^ Column name String in SQL+      -> StringSQL -- ^ Column name String in SQL index =  (!) . unType  -- | Cast phantom type into 'Maybe' type.@@ -83,9 +59,9 @@  -- | Unsafely generate phantom typed table type. table :: String -> [String] -> Table r-table n f = Table $ Untyped.Untyped n w fa  where+table n f = Table $ Untyped n w fa  where   w  = length f-  fa = listArray (0, w - 1) $ map columnSQL f+  fa = listArray (0, w - 1) $ map stringSQL f  -- | Inference rule of 'Table' existence. class PersistableWidth r => TableDerivable r where

@@ -308,6 +308,52 @@   , 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++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"+  ]++_p_cases :: IO ()+_p_cases =+  mapM_ print [show caseSearchX, show caseX]+ nothingX :: Relation () (SetA, Maybe SetB) nothingX =  relation $ do   a <- query setA@@ -630,7 +676,7 @@  tests :: [Test] tests =-  concat [ tables, monadic, directJoins, join3s, nested, bin, uni+  concat [ tables, monadic, directJoins, join3s, nested, bin, cases, uni          , groups, orders, partitions, exps, effs, correlated]  main :: IO ()