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 ()
