Hello community, here is the log from the commit of package ghc-relational-query for openSUSE:Factory checked in at 2017-06-04 01:58:38 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-relational-query (Old) and /work/SRC/openSUSE:Factory/.ghc-relational-query.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-relational-query" Sun Jun 4 01:58:38 2017 rev:6 rq:499724 version:0.8.4.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-relational-query/ghc-relational-query.changes 2017-05-06 18:28:59.424823896 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-relational-query.new/ghc-relational-query.changes 2017-06-04 01:58:40.633963583 +0200 @@ -1,0 +2,5 @@ +Thu May 18 09:52:23 UTC 2017 - psim...@suse.com + +- Update to version 0.8.4.0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- relational-query-0.8.3.6.tar.gz New: ---- relational-query-0.8.4.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-relational-query.spec ++++++ --- /var/tmp/diff_new_pack.vk3WBo/_old 2017-06-04 01:58:41.181886175 +0200 +++ /var/tmp/diff_new_pack.vk3WBo/_new 2017-06-04 01:58:41.185885610 +0200 @@ -19,7 +19,7 @@ %global pkg_name relational-query %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.8.3.6 +Version: 0.8.4.0 Release: 0 Summary: Typeful, Modular, Relational, algebraic query engine License: BSD-3-Clause ++++++ relational-query-0.8.3.6.tar.gz -> relational-query-0.8.4.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/ChangeLog.md new/relational-query-0.8.4.0/ChangeLog.md --- old/relational-query-0.8.3.6/ChangeLog.md 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/ChangeLog.md 2017-05-08 23:31:26.000000000 +0200 @@ -1,5 +1,17 @@ <!-- -*- Markdown -*- --> +## 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 + +- Add version constraint for LTS-8. + ## 0.8.3.6 - Bugfix of lazy instances of ShowConstantTermsSQL. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/relational-query.cabal new/relational-query-0.8.4.0/relational-query.cabal --- old/relational-query-0.8.3.6/relational-query.cabal 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/relational-query.cabal 2017-05-08 23:31:26.000000000 +0200 @@ -1,5 +1,5 @@ name: relational-query -version: 0.8.3.6 +version: 0.8.4.0 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can @@ -89,7 +89,7 @@ , th-reify-compat , sql-words >=0.1.4 , names-th - , persistable-record >= 0.3 + , persistable-record >=0.3 && <0.5 hs-source-dirs: src ghc-options: -Wall -fsimpl-tick-factor=200 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Component.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Component.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Component.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Component.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/BaseSQL.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/BaseSQL.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/BaseSQL.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/BaseSQL.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/GroupingSQL.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/GroupingSQL.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/GroupingSQL.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/GroupingSQL.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/SQL.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/SQL.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/SQL.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/SQL.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/Sub.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/Sub.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/Sub.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/Sub.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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,7 +159,7 @@ 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 @@ -153,6 +167,38 @@ projectFromScalarSubQuery :: SubQuery -> Projection c t projectFromScalarSubQuery = typedProjection . (:[]) . Scalar +whenClauses :: String -- ^ Error tag + -> [(Projection c a, Projection c b)] -- ^ Each when clauses + -> Projection c b -- ^ Else result projection + -> WhenClauses -- ^ Result clause +whenClauses eTag ws0 e = d ws0 + where + d [] = error $ eTag ++ ": Empty when clauses!" + d ws@(_:_) = + WhenClauses [ (untypeProjection p, untypeProjection r) | (p, r) <- ws ] + $ untypeProjection e + +-- | Search case operator correnponding SQL search /CASE/. +-- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ +caseSearch :: [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses + -> Projection c a -- ^ Else result projection + -> Projection c a -- ^ Result projection +caseSearch ws e = + typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ] + where + c = CaseSearch $ whenClauses "caseSearch" ws e + +-- | Simple case operator correnponding SQL simple /CASE/. +-- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ +case' :: Projection c a -- ^ Projection value to match + -> [(Projection c a, Projection c b)] -- ^ Each when clauses + -> Projection c b -- ^ Else result projection + -> Projection c b -- ^ Result projection +case' v ws e = + typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ] + where + c = CaseSimple (untypeProjection v) $ whenClauses "case'" ws e + -- | Type for restriction of query. type QueryRestriction c = [Projection c (Maybe Bool)] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/UntypedTable.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/UntypedTable.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Internal/UntypedTable.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Internal/UntypedTable.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Monad/Aggregate.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Monad/Aggregate.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Monad/Aggregate.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Monad/Aggregate.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Projectable.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Projectable.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Projectable.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Projectable.hs 2017-05-08 23:31:26.000000000 +0200 @@ -21,7 +21,7 @@ value, valueTrue, valueFalse, values, - unsafeValueNull, + nothing, unsafeValueNull, -- * Placeholders PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders, @@ -67,17 +67,18 @@ 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, PersistableRecordWidth, derivedWidth, + (PersistableWidth, 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.Context (Flat, Aggregated, Exists, OverWindow) import Database.Relational.Query.Pure @@ -125,9 +126,19 @@ unsafeProjectSql :: SqlProjectable p => String -> p t unsafeProjectSql = unsafeProjectSql' . stringSQL --- | Polymorphic projection of SQL null value. -unsafeValueNull :: OperatorProjectable p => p (Maybe a) -unsafeValueNull = unsafeProjectSql "NULL" +-- | 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 -- | Generate polymorphic projection of SQL constant values from Haskell value. value :: (ShowConstantTermsSQL t, OperatorProjectable p) => t -> p t @@ -360,59 +371,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 -}, PersistableWidth a) + => [(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 -}, 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 v cs = case' v cs unsafeValueNull -- | Binary operator corresponding SQL /IN/ . diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Projection.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Projection.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Projection.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Projection.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/SQL.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/SQL.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/SQL.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/SQL.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Sub.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Sub.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Sub.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Sub.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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,54 +243,48 @@ 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 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/src/Database/Relational/Query/Table.hs new/relational-query-0.8.4.0/src/Database/Relational/Query/Table.hs --- old/relational-query-0.8.3.6/src/Database/Relational/Query/Table.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/src/Database/Relational/Query/Table.hs 2017-05-08 23:31:26.000000000 +0200 @@ -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,29 +20,9 @@ import Database.Record (PersistableWidth) -import qualified Database.Relational.Query.Internal.UntypedTable as Untyped -import Database.Relational.Query.Internal.SQL (ColumnSQL, columnSQL) - - -{-# 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' +import Database.Relational.Query.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!)) +import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, ) --- | 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/relational-query-0.8.3.6/test/sqlsEq.hs new/relational-query-0.8.4.0/test/sqlsEq.hs --- old/relational-query-0.8.3.6/test/sqlsEq.hs 2017-04-04 09:32:05.000000000 +0200 +++ new/relational-query-0.8.4.0/test/sqlsEq.hs 2017-05-08 23:31:26.000000000 +0200 @@ -308,6 +308,63 @@ , 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 @@ -630,7 +687,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 ()