diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ +## 0.8.3.5 + +- Deprecate some exported interfaces which are internal definitions. + ## 0.8.3.4 - Update this changelog diff --git a/relational-query.cabal b/relational-query.cabal --- a/relational-query.cabal +++ b/relational-query.cabal @@ -1,5 +1,5 @@ name: relational-query -version: 0.8.3.4 +version: 0.8.3.5 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can @@ -14,7 +14,7 @@ license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com -copyright: Copyright (c) 2013-2016 Kei Hibino +copyright: Copyright (c) 2013-2017 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 @@ -65,7 +65,12 @@ Database.Relational.Query.TH other-modules: + Database.Relational.Query.Internal.Config + Database.Relational.Query.Internal.ContextType Database.Relational.Query.Internal.SQL + Database.Relational.Query.Internal.BaseSQL + Database.Relational.Query.Internal.GroupingSQL + Database.Relational.Query.Internal.UntypedTable Database.Relational.Query.Internal.Product Database.Relational.Query.Internal.Sub Database.Relational.Query.Monad.Trans.JoinState diff --git a/src/Database/Relational/Query.hs b/src/Database/Relational/Query.hs --- a/src/Database/Relational/Query.hs +++ b/src/Database/Relational/Query.hs @@ -51,7 +51,9 @@ Primary, Unique, NotNull) import Database.Relational.Query.Context import Database.Relational.Query.Component - (NameConfig (..), SchemaNameMode (..), Config (..), defaultConfig, ProductUnitSupport (..), IdentifierQuotation (..), Order (..)) + (NameConfig (..), SchemaNameMode (..), ProductUnitSupport (..), IdentifierQuotation (..), + Config (..), defaultConfig, + AggregateKey, Order (..)) import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth) import Database.Relational.Query.Projection (Projection, list) import Database.Relational.Query.Projectable diff --git a/src/Database/Relational/Query/Arrow.hs b/src/Database/Relational/Query/Arrow.hs --- a/src/Database/Relational/Query/Arrow.hs +++ b/src/Database/Relational/Query/Arrow.hs @@ -3,7 +3,7 @@ -- | -- Module : Database.Relational.Query.Arrow --- Copyright : 2015 Kei Hibino +-- Copyright : 2015-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -65,6 +65,7 @@ import Control.Arrow (Arrow, Kleisli (..)) import Database.Record + import Database.Relational.Query hiding (all', distinct, query, queryMaybe, query', queryMaybe', @@ -78,7 +79,6 @@ QuerySimple, QueryAggregate, QueryUnique, Window) import qualified Database.Relational.Query as Monadic import Database.Relational.Query.Projection (ListProjection) -import Database.Relational.Query.Component (AggregateKey) import qualified Database.Relational.Query.Monad.Trans.Aggregating as Monadic import qualified Database.Relational.Query.Monad.Trans.Ordering as Monadic import qualified Database.Relational.Query.Monad.Trans.Assigning as Monadic diff --git a/src/Database/Relational/Query/Component.hs b/src/Database/Relational/Query/Component.hs --- a/src/Database/Relational/Query/Component.hs +++ b/src/Database/Relational/Query/Component.hs @@ -1,10 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Component --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -14,285 +13,215 @@ -- 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 - NameConfig (..), - SchemaNameMode (..), - Config ( productUnitSupport - , chunksInsertSize - , schemaNameMode - , normalizedTableName - , verboseAsCompilerWarning - , nameConfig - , identifierQuotation), - defaultConfig, - ProductUnitSupport (..), Duplication (..), IdentifierQuotation (..), + module Database.Relational.Query.Internal.Config, -- * Duplication attribute - showsDuplication, + -- deprecated interfaces - import Duplication from internal module + Duplication (..), showsDuplication, -- * Types for aggregation - AggregateColumnRef, + AggregateKey, + -- deprecated interfaces + AggregateColumnRef, AggregateBitKey, AggregateSet, AggregateElem, - aggregateColumnRef, aggregateEmpty, aggregatePowerKey, aggregateGroupingSet, aggregateRollup, aggregateCube, aggregateSets, - composeGroupBy, composePartitionBy, - - AggregateKey, aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey, + aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey, -- * Types for ordering - Order (..), OrderColumn, OrderingTerm, OrderingTerms, - composeOrderBy, + Order (..), + -- deprecated interfaces + OrderColumn, OrderingTerm, composeOrderBy, + + -- deprecated interfaces + OrderingTerms, + -- * Types for assignments - AssignColumn, AssignTerm, Assignment, Assignments, composeSets, composeValues, + -- deprecated interfaces + AssignColumn, AssignTerm, Assignment, composeSets, composeValues, + -- deprecated interfaces + Assignments, + -- * Compose window clause composeOver, ) where -import Data.Monoid (Monoid (..), (<>)) - -import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowConsStringSQL) -import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) +import Data.Monoid ((<>)) +import Language.SQL.Keyword (Keyword(..)) import qualified Language.SQL.Keyword as SQL -import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) -import qualified Database.Record.TH as RecordTH +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.GroupingSQL (AggregateKey) +import qualified Database.Relational.Query.Internal.GroupingSQL as GroupingSQL --- | Simple wrap type -newtype ColumnSQL' a = ColumnSQL a -instance Functor ColumnSQL' where - fmap f (ColumnSQL c) = ColumnSQL $ f c - +{-# DEPRECATED + ColumnSQL, + columnSQL, columnSQL', showsColumnSQL + "prepare to drop public interface. internally use Database.Relational.Query.Internal.SQL.*" #-} -- | Column SQL string type -type ColumnSQL = ColumnSQL' StringSQL +type ColumnSQL = Internal.ColumnSQL -- | 'ColumnSQL' from string columnSQL :: String -> ColumnSQL -columnSQL = columnSQL' . stringSQL +columnSQL = Internal.columnSQL -- | 'ColumnSQL' from 'StringSQL' columnSQL' :: StringSQL -> ColumnSQL -columnSQL' = ColumnSQL - --- | String from ColumnSQL -stringFromColumnSQL :: ColumnSQL -> String -stringFromColumnSQL = showStringSQL . showsColumnSQL +columnSQL' = Internal.columnSQL' -- | StringSQL from ColumnSQL showsColumnSQL :: ColumnSQL -> StringSQL -showsColumnSQL (ColumnSQL c) = c +showsColumnSQL = Internal.showsColumnSQL -instance Show ColumnSQL where - show = stringFromColumnSQL --- | 'NameConfig' type to customize names of expanded templates. -data NameConfig = - NameConfig - { recordConfig :: RecordTH.NameConfig - , relationVarName :: String -> String -> VarName - } +{-# 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 -instance Show NameConfig where - show = const "" --- | Schema name qualify mode in SQL string. -data SchemaNameMode - = SchemaQualified -- ^ Schema qualified table name in SQL string - | SchemaNotQualified -- ^ Not qualified table name in SQL string - deriving (Eq, Show) - --- | Configuration type. -data Config = - Config - { productUnitSupport :: !ProductUnitSupport - , chunksInsertSize :: !Int - , schemaNameMode :: !SchemaNameMode - , normalizedTableName :: !Bool - , verboseAsCompilerWarning :: !Bool - , nameConfig :: !NameConfig - , identifierQuotation :: !IdentifierQuotation - } deriving Show - --- | Default configuration. -defaultConfig :: Config -defaultConfig = - Config { productUnitSupport = PUSupported - , chunksInsertSize = 256 - , schemaNameMode = SchemaQualified - , normalizedTableName = True - , verboseAsCompilerWarning = False - , nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig - , relationVarName = const varCamelcaseName - } - , identifierQuotation = NoQuotation - } - --- | Unit of product is supported or not. -data ProductUnitSupport = PUSupported | PUNotSupported deriving Show - --- | Configuration for quotation of identifiers of SQL. -data IdentifierQuotation = NoQuotation | Quotation Char deriving Show +{-# DEPRECATED + AggregateColumnRef, + AggregateBitKey, AggregateSet, AggregateElem, --- | Result record duplication attribute -data Duplication = All | Distinct deriving Show + aggregateColumnRef, aggregateEmpty, + aggregatePowerKey, aggregateGroupingSet, + aggregateRollup, aggregateCube, aggregateSets, --- | Compose duplication attribute string. -showsDuplication :: Duplication -> StringSQL -showsDuplication = dup where - dup All = ALL - dup Distinct = DISTINCT + composeGroupBy, composePartitionBy, + aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey + "prepare to drop public interface. internally use Database.Relational.Query.Internal.GroupingSQL.*" #-} -- | Type for group-by term -type AggregateColumnRef = ColumnSQL +type AggregateColumnRef = GroupingSQL.AggregateColumnRef -- | Type for group key. -newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show +type AggregateBitKey = GroupingSQL.AggregateBitKey -- | Type for grouping set -newtype AggregateSet = AggregateSet [AggregateElem] deriving Show +type AggregateSet = GroupingSQL.AggregateSet -- | Type for group-by tree -data AggregateElem = ColumnRef AggregateColumnRef - | Rollup [AggregateBitKey] - | Cube [AggregateBitKey] - | GroupingSets [AggregateSet] - deriving Show +type AggregateElem = GroupingSQL.AggregateElem -- | Single term aggregation element. aggregateColumnRef :: AggregateColumnRef -> AggregateElem -aggregateColumnRef = ColumnRef +aggregateColumnRef = GroupingSQL.aggregateColumnRef -- | Key of aggregation power set. aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey -aggregatePowerKey = AggregateBitKey +aggregatePowerKey = GroupingSQL.aggregatePowerKey -- | Single grouping set. aggregateGroupingSet :: [AggregateElem] -> AggregateSet -aggregateGroupingSet = AggregateSet +aggregateGroupingSet = GroupingSQL.aggregateGroupingSet -- | Rollup aggregation element. aggregateRollup :: [AggregateBitKey] -> AggregateElem -aggregateRollup = Rollup +aggregateRollup = GroupingSQL.aggregateRollup -- | Cube aggregation element. aggregateCube :: [AggregateBitKey] -> AggregateElem -aggregateCube = Cube +aggregateCube = GroupingSQL.aggregateCube -- | Grouping sets aggregation. aggregateSets :: [AggregateSet] -> AggregateElem -aggregateSets = GroupingSets +aggregateSets = GroupingSQL.aggregateSets -- | Empty aggregation. aggregateEmpty :: [AggregateElem] -aggregateEmpty = [] - -showsAggregateColumnRef :: AggregateColumnRef -> StringSQL -showsAggregateColumnRef = showsColumnSQL - -commaed :: [StringSQL] -> StringSQL -commaed = SQL.fold (|*|) - -pComma :: (a -> StringSQL) -> [a] -> StringSQL -pComma qshow = SQL.paren . commaed . map qshow - -showsAggregateBitKey :: AggregateBitKey -> StringSQL -showsAggregateBitKey (AggregateBitKey ts) = pComma showsAggregateColumnRef ts +aggregateEmpty = GroupingSQL.aggregateEmpty -- | Compose GROUP BY clause from AggregateElem list. composeGroupBy :: [AggregateElem] -> StringSQL -composeGroupBy = d where - d [] = mempty - d es@(_:_) = GROUP <> BY <> rec es - keyList op ss = op <> pComma showsAggregateBitKey ss - rec = commaed . map showsE - showsGs (AggregateSet s) = SQL.paren $ rec s - showsE (ColumnRef t) = showsAggregateColumnRef t - showsE (Rollup ss) = keyList ROLLUP ss - showsE (Cube ss) = keyList CUBE ss - showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss +composeGroupBy = GroupingSQL.composeGroupBy -- | Compose PARTITION BY clause from AggregateColumnRef list. composePartitionBy :: [AggregateColumnRef] -> StringSQL -composePartitionBy = d where - d [] = mempty - d ts@(_:_) = PARTITION <> BY <> commaed (map showsAggregateColumnRef ts) - --- | Typeful aggregate element. -newtype AggregateKey a = AggregateKey (a, AggregateElem) +composePartitionBy = GroupingSQL.composePartitionBy -- | Extract typed projection from 'AggregateKey'. aggregateKeyProjection :: AggregateKey a -> a -aggregateKeyProjection (AggregateKey (p, _c)) = p +aggregateKeyProjection = GroupingSQL.aggregateKeyProjection -- | Extract untyped term from 'AggregateKey'. aggregateKeyElement :: AggregateKey a -> AggregateElem -aggregateKeyElement (AggregateKey (_p, c)) = c +aggregateKeyElement = GroupingSQL.aggregateKeyElement -- | Unsafely bind typed-projection and untyped-term into 'AggregateKey'. unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a -unsafeAggregateKey = AggregateKey +unsafeAggregateKey = GroupingSQL.unsafeAggregateKey --- | Order direction. Ascendant or Descendant. -data Order = Asc | Desc deriving Show +{-# 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 = ColumnSQL +type OrderColumn = BaseSQL.OrderColumn -- | Type for order-by term -type OrderingTerm = (Order, OrderColumn) - --- | Type for order-by terms -type OrderingTerms = [OrderingTerm] +type OrderingTerm = BaseSQL.OrderingTerm -- | Compose ORDER BY clause from OrderingTerms -composeOrderBy :: OrderingTerms -> StringSQL -composeOrderBy = d where - d [] = mempty - d ts@(_:_) = ORDER <> BY <> commaed (map showsOt ts) - showsOt (o, e) = showsColumnSQL e <> order o - order Asc = ASC - order Desc = DESC +composeOrderBy :: [OrderingTerm] -> StringSQL +composeOrderBy = BaseSQL.composeOrderBy --- | Column SQL String -type AssignColumn = ColumnSQL +{-# DEPRECATED Assignments "use [Assignment]." #-} +-- | Assignment pair list. +type Assignments = [Assignment] --- | Value SQL String -type AssignTerm = ColumnSQL +{-# 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 --- | Assignment pair -type Assignment = (AssignColumn, AssignTerm) +-- | Value SQL String of assignment +type AssignTerm = BaseSQL.AssignTerm --- | Assignment pair list. -type Assignments = [Assignment] +-- | Assignment pair +type Assignment = BaseSQL.Assignment --- | Compose SET clause from 'Assignments'. -composeSets :: Assignments -> StringSQL -composeSets as = assigns where - assignList = foldr (\ (col, term) r -> - (showsColumnSQL col .=. showsColumnSQL term) : r) - [] as - assigns | null assignList = error "Update assignment list is null!" - | otherwise = SET <> commaed assignList +-- | Compose SET clause from ['Assignment']. +composeSets :: [Assignment] -> StringSQL +composeSets = BaseSQL.composeSets --- | Compose VALUES clause from 'Assignments'. -composeValues :: Assignments -> StringSQL -composeValues as = rowConsStringSQL [ showsColumnSQL c | c <- cs ] <> VALUES <> - rowConsStringSQL [ showsColumnSQL c | c <- vs ] where - (cs, vs) = unzip as +-- | Compose 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 = diff --git a/src/Database/Relational/Query/Constraint.hs b/src/Database/Relational/Query/Constraint.hs --- a/src/Database/Relational/Query/Constraint.hs +++ b/src/Database/Relational/Query/Constraint.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Constraint --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -33,14 +33,14 @@ ) where -import Database.Relational.Query.Pi (Pi) -import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi +import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) import Database.Record.KeyConstraint (KeyConstraint, unsafeSpecifyKeyConstraint, Primary, Unique, NotNull) - import qualified Database.Record.KeyConstraint as C -import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) + +import Database.Relational.Query.Pi (Pi) +import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi -- | Constraint Key proof object. Constraint type 'c', record type 'r' and columns type 'ct'. diff --git a/src/Database/Relational/Query/Context.hs b/src/Database/Relational/Query/Context.hs --- a/src/Database/Relational/Query/Context.hs +++ b/src/Database/Relational/Query/Context.hs @@ -1,39 +1,15 @@ -{-# LANGUAGE EmptyDataDecls #-} - -- | -- Module : Database.Relational.Query.Context --- Copyright : 2013 Kei Hibino +-- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- --- This module defines query context tag types. -module Database.Relational.Query.Context ( - Flat, Aggregated, Exists, OverWindow, - - Set, SetList, Power, - ) where - --- | Type tag for flat (not-aggregated) query -data Flat - --- | Type tag for aggregated query -data Aggregated - --- | Type tag for exists predicate -data Exists - --- | Type tag for window function building -data OverWindow - - --- | Type tag for normal aggregatings set -data Set - --- | Type tag for aggregatings GROUPING SETS -data SetList +-- This module re-export query context tag types. +module Database.Relational.Query.Context + ( module Database.Relational.Query.Internal.ContextType + ) where --- | Type tag for aggregatings power set -data Power +import Database.Relational.Query.Internal.ContextType diff --git a/src/Database/Relational/Query/Derives.hs b/src/Database/Relational/Query/Derives.hs --- a/src/Database/Relational/Query/Derives.hs +++ b/src/Database/Relational/Query/Derives.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Derives --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -30,6 +30,7 @@ import Database.Record (PersistableWidth, ToSql (recordToSql)) import Database.Record.ToSql (unsafeUpdateValuesWithIndexes) + import Database.Relational.Query.Table (Table, TableDerivable) import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes) import Database.Relational.Query.Projection (Projection) diff --git a/src/Database/Relational/Query/Effect.hs b/src/Database/Relational/Query/Effect.hs --- a/src/Database/Relational/Query/Effect.hs +++ b/src/Database/Relational/Query/Effect.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Effect --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -29,18 +29,20 @@ import Data.Monoid ((<>)) +import Language.SQL.Keyword (Keyword(..)) import Database.Record (PersistableWidth) +import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) +import Database.Relational.Query.Internal.BaseSQL (composeSets, composeValues) + import Database.Relational.Query.Pi (id') import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import qualified Database.Relational.Query.Table as Table -import Database.Relational.Query.Component (Config, defaultConfig, composeSets, composeValues) import Database.Relational.Query.Sub (composeWhere) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, placeholder, unitPlaceHolder, unsafeAddPlaceHolders, (><), rightId) - import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#)) import Database.Relational.Query.Monad.Restrict (RestrictedStatement) import qualified Database.Relational.Query.Monad.Restrict as Restrict @@ -48,8 +50,6 @@ import qualified Database.Relational.Query.Monad.Assign as Assign import Database.Relational.Query.Monad.Register (Register) import qualified Database.Relational.Query.Monad.Register as Register - -import Language.SQL.Keyword (Keyword(..)) -- | Restriction type with place-holder parameter 'p' and projection record type 'r'. diff --git a/src/Database/Relational/Query/Internal/BaseSQL.hs b/src/Database/Relational/Query/Internal/BaseSQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/BaseSQL.hs @@ -0,0 +1,77 @@ +-- | +-- Module : Database.Relational.Query.Internal.BaseSQL +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides base structure of SQL syntax tree. +module Database.Relational.Query.Internal.BaseSQL ( + Duplication (..), showsDuplication, + Order (..), OrderColumn, OrderingTerm, composeOrderBy, + AssignColumn, AssignTerm, Assignment, composeSets, composeValues, + ) where + +import Data.Monoid (Monoid (..), (<>)) + +import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Query.Internal.SQL + (StringSQL, rowConsStringSQL, ColumnSQL, showsColumnSQL) + + +-- | Result record duplication attribute +data Duplication = All | Distinct deriving Show + +-- | Compose duplication attribute string. +showsDuplication :: Duplication -> StringSQL +showsDuplication = dup where + dup All = ALL + dup Distinct = DISTINCT + + +-- | Order direction. Ascendant or Descendant. +data Order = Asc | Desc deriving Show + +-- | Type for order-by column +type OrderColumn = ColumnSQL + +-- | Type for order-by term +type OrderingTerm = (Order, OrderColumn) + +-- | Compose ORDER BY clause from OrderingTerms +composeOrderBy :: [OrderingTerm] -> StringSQL +composeOrderBy = d where + d [] = mempty + d ts@(_:_) = ORDER <> BY <> SQL.fold (|*|) (map showsOt ts) + showsOt (o, e) = showsColumnSQL e <> order o + order Asc = ASC + order Desc = DESC + + +-- | Column SQL String of assignment +type AssignColumn = ColumnSQL + +-- | Value SQL String of assignment +type AssignTerm = ColumnSQL + +-- | Assignment pair +type Assignment = (AssignColumn, AssignTerm) + +-- | Compose SET clause from ['Assignment']. +composeSets :: [Assignment] -> StringSQL +composeSets as = assigns where + assignList = foldr (\ (col, term) r -> + (showsColumnSQL col .=. showsColumnSQL 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 + (cs, vs) = unzip as diff --git a/src/Database/Relational/Query/Internal/Config.hs b/src/Database/Relational/Query/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/Config.hs @@ -0,0 +1,74 @@ +-- | +-- Module : Database.Relational.Query.Internal.Config +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines configuration datatype used in query products. +module Database.Relational.Query.Internal.Config ( + NameConfig (..), + ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), + Config ( productUnitSupport + , chunksInsertSize + , schemaNameMode + , normalizedTableName + , verboseAsCompilerWarning + , identifierQuotation + , nameConfig), + defaultConfig, + ) where + +import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) +import qualified Database.Record.TH as RecordTH + + +-- | 'NameConfig' type to customize names of expanded templates. +data NameConfig = + NameConfig + { recordConfig :: RecordTH.NameConfig + , relationVarName :: String -> String -> VarName + } + +instance Show NameConfig where + show = const "" + +-- | Unit of product is supported or not. +data ProductUnitSupport = PUSupported | PUNotSupported deriving Show + +-- | Schema name qualify mode in SQL string. +data SchemaNameMode + = SchemaQualified -- ^ Schema qualified table name in SQL string + | SchemaNotQualified -- ^ Not qualified table name in SQL string + deriving (Eq, Show) + +-- | Configuration for quotation of identifiers of SQL. +data IdentifierQuotation = NoQuotation | Quotation Char deriving Show + +-- | Configuration type. +data Config = + Config + { productUnitSupport :: !ProductUnitSupport + , chunksInsertSize :: !Int + , schemaNameMode :: !SchemaNameMode + , normalizedTableName :: !Bool + , verboseAsCompilerWarning :: !Bool + , identifierQuotation :: !IdentifierQuotation + , nameConfig :: !NameConfig + } deriving Show + +-- | Default configuration. +defaultConfig :: Config +defaultConfig = + Config { productUnitSupport = PUSupported + , chunksInsertSize = 256 + , schemaNameMode = SchemaQualified + , normalizedTableName = True + , verboseAsCompilerWarning = False + , identifierQuotation = NoQuotation + , nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig + , relationVarName = const varCamelcaseName + } + } diff --git a/src/Database/Relational/Query/Internal/ContextType.hs b/src/Database/Relational/Query/Internal/ContextType.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/ContextType.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- | +-- Module : Database.Relational.Query.Internal.ContextType +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines query context tag types. +module Database.Relational.Query.Internal.ContextType ( + Flat, Aggregated, Exists, OverWindow, + + Set, SetList, Power, + ) where + +-- | Type tag for flat (not-aggregated) query +data Flat + +-- | Type tag for aggregated query +data Aggregated + +-- | Type tag for exists predicate +data Exists + +-- | Type tag for window function building +data OverWindow + + +-- | Type tag for normal aggregatings set +data Set + +-- | Type tag for aggregatings GROUPING SETS +data SetList + +-- | Type tag for aggregatings power set +data Power diff --git a/src/Database/Relational/Query/Internal/GroupingSQL.hs b/src/Database/Relational/Query/Internal/GroupingSQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/GroupingSQL.hs @@ -0,0 +1,122 @@ +-- | +-- Module : Database.Relational.Query.Internal.GroupingSQL +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides grouping-sets structure of SQL syntax tree. +module Database.Relational.Query.Internal.GroupingSQL ( + AggregateColumnRef, + AggregateBitKey (..), AggregateSet (..), AggregateElem (..), + + aggregateColumnRef, aggregateEmpty, + aggregatePowerKey, aggregateGroupingSet, + aggregateRollup, aggregateCube, aggregateSets, + + composeGroupBy, composePartitionBy, + + AggregateKey (..), + + aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey, + ) where + +import Data.Monoid (Monoid (..), (<>)) + +import Language.SQL.Keyword (Keyword(..), (|*|)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Query.Internal.SQL (StringSQL, ColumnSQL, showsColumnSQL) + + +-- | Type for group-by term +type AggregateColumnRef = ColumnSQL + +-- | Type for group key. +newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show + +-- | Type for grouping set +newtype AggregateSet = AggregateSet [AggregateElem] deriving Show + +-- | Type for group-by tree +data AggregateElem = ColumnRef AggregateColumnRef + | Rollup [AggregateBitKey] + | Cube [AggregateBitKey] + | GroupingSets [AggregateSet] + deriving Show + +-- | Typeful aggregate element. +newtype AggregateKey a = AggregateKey (a, AggregateElem) + +-- | Single term aggregation element. +aggregateColumnRef :: AggregateColumnRef -> AggregateElem +aggregateColumnRef = ColumnRef + +-- | Key of aggregation power set. +aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey +aggregatePowerKey = AggregateBitKey + +-- | Single grouping set. +aggregateGroupingSet :: [AggregateElem] -> AggregateSet +aggregateGroupingSet = AggregateSet + +-- | Rollup aggregation element. +aggregateRollup :: [AggregateBitKey] -> AggregateElem +aggregateRollup = Rollup + +-- | Cube aggregation element. +aggregateCube :: [AggregateBitKey] -> AggregateElem +aggregateCube = Cube + +-- | Grouping sets aggregation. +aggregateSets :: [AggregateSet] -> AggregateElem +aggregateSets = GroupingSets + +-- | Empty aggregation. +aggregateEmpty :: [AggregateElem] +aggregateEmpty = [] + +showsAggregateColumnRef :: AggregateColumnRef -> StringSQL +showsAggregateColumnRef = showsColumnSQL + +commaed :: [StringSQL] -> StringSQL +commaed = SQL.fold (|*|) + +pComma :: (a -> StringSQL) -> [a] -> StringSQL +pComma qshow = SQL.paren . commaed . map qshow + +showsAggregateBitKey :: AggregateBitKey -> StringSQL +showsAggregateBitKey (AggregateBitKey ts) = pComma showsAggregateColumnRef ts + +-- | Compose GROUP BY clause from AggregateElem list. +composeGroupBy :: [AggregateElem] -> StringSQL +composeGroupBy = d where + d [] = mempty + d es@(_:_) = GROUP <> BY <> rec es + keyList op ss = op <> pComma showsAggregateBitKey ss + rec = commaed . map showsE + showsGs (AggregateSet s) = SQL.paren $ rec s + showsE (ColumnRef t) = showsAggregateColumnRef t + showsE (Rollup ss) = keyList ROLLUP ss + showsE (Cube ss) = keyList CUBE ss + showsE (GroupingSets ss) = GROUPING <> SETS <> pComma showsGs ss + +-- | Compose PARTITION BY clause from AggregateColumnRef list. +composePartitionBy :: [AggregateColumnRef] -> StringSQL +composePartitionBy = d where + d [] = mempty + d ts@(_:_) = PARTITION <> BY <> commaed (map showsAggregateColumnRef ts) + +-- | Extract typed projection from 'AggregateKey'. +aggregateKeyProjection :: AggregateKey a -> a +aggregateKeyProjection (AggregateKey (p, _c)) = p + +-- | Extract untyped term from 'AggregateKey'. +aggregateKeyElement :: AggregateKey a -> AggregateElem +aggregateKeyElement (AggregateKey (_p, c)) = c + +-- | Unsafely bind typed-projection and untyped-term into 'AggregateKey'. +unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a +unsafeAggregateKey = AggregateKey diff --git a/src/Database/Relational/Query/Internal/Product.hs b/src/Database/Relational/Query/Internal/Product.hs --- a/src/Database/Relational/Query/Internal/Product.hs +++ b/src/Database/Relational/Query/Internal/Product.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Internal.Product --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -17,7 +17,7 @@ import Control.Applicative (pure) import Data.Monoid ((<>), mempty) -import Database.Relational.Query.Context (Flat) +import Database.Relational.Query.Internal.ContextType (Flat) import Database.Relational.Query.Internal.Sub (NodeAttr (..), ProductTree (..), Node (..), Projection, Qualified, SubQuery, ProductTreeBuilder, ProductBuilder) diff --git a/src/Database/Relational/Query/Internal/SQL.hs b/src/Database/Relational/Query/Internal/SQL.hs --- a/src/Database/Relational/Query/Internal/SQL.hs +++ b/src/Database/Relational/Query/Internal/SQL.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE FlexibleInstances #-} + -- | -- Module : Database.Relational.Query.Internal.SQL --- Copyright : 2014 Kei Hibino +-- Copyright : 2014-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -14,6 +16,8 @@ rowStringSQL, rowPlaceHolderStringSQL, rowConsStringSQL, listStringSQL, + + ColumnSQL, columnSQL, columnSQL', showsColumnSQL, ) where import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren) @@ -48,3 +52,28 @@ -- | 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 --git a/src/Database/Relational/Query/Internal/Sub.hs b/src/Database/Relational/Query/Internal/Sub.hs --- a/src/Database/Relational/Query/Internal/Sub.hs +++ b/src/Database/Relational/Query/Internal/Sub.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | -- Module : Database.Relational.Query.Internal.Sub --- Copyright : 2015-2016 Kei Hibino +-- Copyright : 2015-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -11,29 +11,35 @@ -- -- This module defines sub-query structure used in query products. module Database.Relational.Query.Internal.Sub - ( SubQuery (..), UntypedProjection, ProjectionUnit (..) - , SetOp (..), BinOp (..), Qualifier (..), Qualified (..) + ( SubQuery (..) + , SetOp (..), BinOp (..), Qualifier (..) + , Qualified (..), qualifier, unQualify, qualify -- * Product tree type - , NodeAttr (..), ProductTree (..), Node (..) + , NodeAttr (..), ProductTree (..) + , Node (..), nodeAttr, nodeTree , JoinProduct, QueryProductTree , ProductTreeBuilder, ProductBuilder - , Projection, untypeProjection, typedProjection + , UntypedProjection, untypedProjectionWidth, ProjectionUnit (..) + , Projection, untypeProjection, typedProjection, projectionWidth + , projectFromColumns, projectFromScalarSubQuery -- * Query restriction , QueryRestriction ) where import Prelude hiding (and, product) -import Data.Array (Array) import Data.DList (DList) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) -import Database.Relational.Query.Context (Flat, Aggregated) -import Database.Relational.Query.Component - (ColumnSQL, Config, Duplication (..), - AggregateElem, OrderingTerms) -import qualified Database.Relational.Query.Table as Table +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.BaseSQL (Duplication (..), OrderingTerm) +import Database.Relational.Query.Internal.GroupingSQL (AggregateElem) +import Database.Relational.Query.Internal.UntypedTable (Untyped) -- | Set operators @@ -43,13 +49,13 @@ newtype BinOp = BinOp (SetOp, Duplication) deriving Show -- | Sub-query type -data SubQuery = Table Table.Untyped +data SubQuery = Table Untyped | Flat Config UntypedProjection Duplication JoinProduct (QueryRestriction Flat) - OrderingTerms + [OrderingTerm] | Aggregated Config UntypedProjection Duplication JoinProduct (QueryRestriction Flat) - [AggregateElem] (QueryRestriction Aggregated) OrderingTerms + [AggregateElem] (QueryRestriction Aggregated) [OrderingTerm] | Bin BinOp SubQuery SubQuery deriving Show @@ -57,20 +63,21 @@ newtype Qualifier = Qualifier Int deriving Show -- | Qualified query. -data Qualified a = Qualified a Qualifier deriving Show +data Qualified a = + Qualified Qualifier a + deriving (Show, Functor, Foldable, Traversable) --- | 'Functor' instance of 'Qualified' -instance Functor Qualified where - fmap f (Qualified a i) = Qualified (f a) i +-- | Get qualifier +qualifier :: Qualified a -> Qualifier +qualifier (Qualified q _) = q --- | Projection structure unit -data ProjectionUnit = Columns (Array Int ColumnSQL) - | Normalized (Qualified Int) - | Scalar SubQuery - deriving Show +-- | Unqualify. +unQualify :: Qualified a -> a +unQualify (Qualified _ a) = a --- | Untyped projection. Forgot record type. -type UntypedProjection = [ProjectionUnit] +-- | Add qualifier +qualify :: Qualifier -> a -> Qualified a +qualify = Qualified -- | node attribute for product. @@ -89,6 +96,14 @@ -- | Product node. node attribute and product tree. data Node rs = Node !NodeAttr !(ProductTree rs) deriving (Show, Functor) +-- | Get node attribute. +nodeAttr :: Node rs -> NodeAttr +nodeAttr (Node a _) = a where + +-- | Get tree from node. +nodeTree :: Node rs -> ProductTree rs +nodeTree (Node _ t) = t + -- | Product tree with join restriction. type QueryProductTree = ProductTree (QueryRestriction Flat) @@ -102,6 +117,20 @@ type JoinProduct = Maybe QueryProductTree +-- | Projection structure unit with single column width +data ProjectionUnit + = RawColumn ColumnSQL -- ^ used in immediate value or unsafe operations + | SubQueryRef (Qualified Int) -- ^ normalized sub-query reference T with Int index + | Scalar SubQuery -- ^ scalar sub-query + deriving Show + +-- | Untyped projection. Forgot record type. +type UntypedProjection = [ProjectionUnit] + +-- | Width of 'UntypedProjection'. +untypedProjectionWidth :: UntypedProjection -> Int +untypedProjectionWidth = length + -- | Phantom typed projection. Projected into Haskell record type 't'. newtype Projection c t = Projection @@ -110,6 +139,19 @@ -- | Unsafely type projection value. typedProjection :: UntypedProjection -> Projection c t typedProjection = Projection + +-- | Width of 'Projection'. +projectionWidth :: Projection c r -> Int +projectionWidth = length . untypeProjection + +-- | Unsafely generate 'Projection' from SQL string list. +projectFromColumns :: [ColumnSQL] -- ^ SQL string list specifies columns + -> Projection c r -- ^ Result 'Projection' +projectFromColumns = typedProjection . map RawColumn + +-- | Unsafely generate 'Projection' from scalar sub-query. +projectFromScalarSubQuery :: SubQuery -> Projection c t +projectFromScalarSubQuery = typedProjection . (:[]) . Scalar -- | Type for restriction of query. diff --git a/src/Database/Relational/Query/Internal/UntypedTable.hs b/src/Database/Relational/Query/Internal/UntypedTable.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/Internal/UntypedTable.hs @@ -0,0 +1,44 @@ +-- | +-- Module : Database.Relational.Query.Internal.UntypedTable +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines no-phantom table type which has table metadatas. +module Database.Relational.Query.Internal.UntypedTable ( + Untyped (Untyped), name', width', columns', (!), + ) where + +import Data.Array (Array, elems) +import qualified Data.Array as Array + +import Database.Relational.Query.Internal.SQL (ColumnSQL) + + +-- | Untyped typed table type +data Untyped = Untyped String Int (Array Int ColumnSQL) deriving Show + +-- | Name string of table in SQL +name' :: Untyped -> String +name' (Untyped n _ _) = n + +-- | Width of table +width' :: Untyped -> Int +width' (Untyped _ w _) = w + +-- | Column name strings in SQL +columnArray :: Untyped -> Array Int ColumnSQL +columnArray (Untyped _ _ c) = c + +-- | Column name strings in SQL +columns' :: Untyped -> [ColumnSQL] +columns' = elems . columnArray + +-- | Column name string in SQL specified by index +(!) :: Untyped + -> Int -- ^ Column index + -> ColumnSQL -- ^ Column name String in SQL +t ! i = columnArray t Array.! i diff --git a/src/Database/Relational/Query/Monad/Aggregate.hs b/src/Database/Relational/Query/Monad/Aggregate.hs --- a/src/Database/Relational/Query/Monad/Aggregate.hs +++ b/src/Database/Relational/Query/Monad/Aggregate.hs @@ -6,7 +6,7 @@ -- | -- Module : Database.Relational.Query.Monad.Aggregate --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -29,15 +29,19 @@ import Data.Functor.Identity (Identity (runIdentity)) import Data.Monoid ((<>)) +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) + import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection -import Database.Relational.Query.Component - (AggregateColumnRef, Duplication, OrderingTerms, AggregateElem, composeOver, showsColumnSQL) import Database.Relational.Query.Sub (SubQuery, QueryRestriction, JoinProduct, aggregatedSubQuery) import qualified Database.Relational.Query.Sub as SubQuery import Database.Relational.Query.Projectable (PlaceHolders, SqlProjectable) - import Database.Relational.Query.Monad.Class (MonadRestrict(..)) import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, restrictings, extractRestrict) @@ -63,7 +67,7 @@ restrict = restrictings . restrict extract :: AggregatedQuery p r - -> ConfigureQuery (((((((PlaceHolders p, Projection Aggregated r), OrderingTerms), + -> ConfigureQuery (((((((PlaceHolders p, Projection Aggregated r), [OrderingTerm]), QueryRestriction Aggregated), [AggregateElem]), QueryRestriction Flat), @@ -83,7 +87,7 @@ c <- askConfig return $ aggregatedSubQuery c (Projection.untype pj) da pd rs ag grs ot -extractWindow :: Window c a -> ((a, OrderingTerms), [AggregateColumnRef]) +extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef]) extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms -- | Operator to make window function result projection using built 'Window' monad. @@ -93,7 +97,7 @@ -> Projection c a wp `over` win = Projection.unsafeFromSqlTerms - [ showsColumnSQL c <> composeOver pt ot + [ showsColumnSQL c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot) | c <- Projection.columns wp ] where (((), ot), pt) = extractWindow win diff --git a/src/Database/Relational/Query/Monad/Assign.hs b/src/Database/Relational/Query/Monad/Assign.hs --- a/src/Database/Relational/Query/Monad/Assign.hs +++ b/src/Database/Relational/Query/Monad/Assign.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Assign --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -19,8 +19,10 @@ extract, ) where +import Database.Relational.Query.Internal.BaseSQL (Assignment) +import Database.Relational.Query.Internal.Config (Config) + import Database.Relational.Query.Sub (QueryRestriction) -import Database.Relational.Query.Component (Config, Assignments) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Table (Table) import Database.Relational.Query.Projection (Projection) @@ -28,6 +30,7 @@ import qualified Database.Relational.Query.Monad.Restrict as Restrict import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments) + -- | Target update monad type used from update statement and merge statement. type Assign r = Assignings r Restrict @@ -42,5 +45,5 @@ -- updateStatement = assignings . restrictings . Identity -- | Run 'Assign'. -extract :: Assign r a -> Config -> ((a, Table r -> Assignments), QueryRestriction Flat) +extract :: Assign r a -> Config -> ((a, Table r -> [Assignment]), QueryRestriction Flat) extract = Restrict.extract . extractAssignments diff --git a/src/Database/Relational/Query/Monad/BaseType.hs b/src/Database/Relational/Query/Monad/BaseType.hs --- a/src/Database/Relational/Query/Monad/BaseType.hs +++ b/src/Database/Relational/Query/Monad/BaseType.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Monad.BaseType --- Copyright : 2015 Kei Hibino +-- Copyright : 2015-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -25,8 +25,9 @@ import Data.Functor.Identity (Identity, runIdentity) import Control.Applicative ((<$>)) -import Database.Relational.Query.Component (Config, defaultConfig) +import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) + import Database.Relational.Query.Sub (Qualified, SubQuery, showSQL) import qualified Database.Relational.Query.Monad.Trans.Qualify as Qualify import Database.Relational.Query.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) diff --git a/src/Database/Relational/Query/Monad/Class.hs b/src/Database/Relational/Query/Monad/Class.hs --- a/src/Database/Relational/Query/Monad/Class.hs +++ b/src/Database/Relational/Query/Monad/Class.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Class --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -21,8 +21,10 @@ on, wheres, having, ) where +import Database.Relational.Query.Internal.BaseSQL (Duplication (..)) +import Database.Relational.Query.Internal.GroupingSQL (AggregateKey) + import Database.Relational.Query.Context (Flat, Aggregated) -import Database.Relational.Query.Component (Duplication (..), AggregateKey) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, Relation) diff --git a/src/Database/Relational/Query/Monad/Register.hs b/src/Database/Relational/Query/Monad/Register.hs --- a/src/Database/Relational/Query/Monad/Register.hs +++ b/src/Database/Relational/Query/Monad/Register.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Monad.Register --- Copyright : 2015 Kei Hibino +-- Copyright : 2015-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -15,7 +15,9 @@ extract, ) where -import Database.Relational.Query.Component (Config, Assignments) +import Database.Relational.Query.Internal.BaseSQL (Assignment) +import Database.Relational.Query.Internal.Config (Config) + import Database.Relational.Query.Table (Table) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, configureQuery) import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments) @@ -25,5 +27,5 @@ type Register r = Assignings r ConfigureQuery -- | Run 'InsertStatement'. -extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> Assignments) +extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> [Assignment]) extract = configureQuery . extractAssignments diff --git a/src/Database/Relational/Query/Monad/Restrict.hs b/src/Database/Relational/Query/Monad/Restrict.hs --- a/src/Database/Relational/Query/Monad/Restrict.hs +++ b/src/Database/Relational/Query/Monad/Restrict.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Restrict --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -20,8 +20,9 @@ extract ) where +import Database.Relational.Query.Internal.Config (Config) + import Database.Relational.Query.Sub (QueryRestriction) -import Database.Relational.Query.Component (Config) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Monad.Trans.Restricting diff --git a/src/Database/Relational/Query/Monad/Simple.hs b/src/Database/Relational/Query/Monad/Simple.hs --- a/src/Database/Relational/Query/Monad/Simple.hs +++ b/src/Database/Relational/Query/Monad/Simple.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Simple --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -26,6 +26,8 @@ import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection +import Database.Relational.Query.Internal.BaseSQL (Duplication, OrderingTerm) + import Database.Relational.Query.Monad.Trans.Join (join') import Database.Relational.Query.Monad.Trans.Restricting (restrictings) import Database.Relational.Query.Monad.Trans.Ordering @@ -34,7 +36,6 @@ import Database.Relational.Query.Monad.Type (QueryCore, extractCore, OrderedQuery) import Database.Relational.Query.Projectable (PlaceHolders) -import Database.Relational.Query.Component (Duplication, OrderingTerms) import Database.Relational.Query.Sub (SubQuery, QueryRestriction, JoinProduct, flatSubQuery) import qualified Database.Relational.Query.Sub as SubQuery @@ -50,7 +51,7 @@ simple = orderings . restrictings . join' extract :: SimpleQuery p r - -> ConfigureQuery (((((PlaceHolders p, Projection Flat r), OrderingTerms), QueryRestriction Flat), + -> ConfigureQuery (((((PlaceHolders p, Projection Flat r), [OrderingTerm]), QueryRestriction Flat), JoinProduct), Duplication) extract = extractCore . extractOrderingTerms diff --git a/src/Database/Relational/Query/Monad/Trans/Aggregating.hs b/src/Database/Relational/Query/Monad/Trans/Aggregating.hs --- a/src/Database/Relational/Query/Monad/Trans/Aggregating.hs +++ b/src/Database/Relational/Query/Monad/Trans/Aggregating.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Aggregating --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -36,14 +36,14 @@ import Data.Functor.Identity (Identity (runIdentity)) -import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList) -import Database.Relational.Query.Component +import Database.Relational.Query.Internal.GroupingSQL (AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets, AggregateKey, aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey) + +import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection - import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) diff --git a/src/Database/Relational/Query/Monad/Trans/Assigning.hs b/src/Database/Relational/Query/Monad/Trans/Assigning.hs --- a/src/Database/Relational/Query/Monad/Trans/Assigning.hs +++ b/src/Database/Relational/Query/Monad/Trans/Assigning.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Assigning --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -24,7 +24,6 @@ extractAssignments ) where -import Database.Relational.Query.Context (Flat) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) @@ -32,12 +31,13 @@ import Data.Monoid (mconcat) import Data.DList (DList, toList) -import Database.Relational.Query.Component (Assignment, Assignments) +import Database.Relational.Query.Internal.BaseSQL (Assignment) + +import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Table (Table) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection - import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..)) @@ -81,5 +81,5 @@ -- | Run 'Assignings' to get 'Assignments' extractAssignments :: (Monad m, Functor m) => Assignings r m a - -> m (a, Table r -> Assignments) + -> m (a, Table r -> [Assignment]) extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac diff --git a/src/Database/Relational/Query/Monad/Trans/Config.hs b/src/Database/Relational/Query/Monad/Trans/Config.hs --- a/src/Database/Relational/Query/Monad/Trans/Config.hs +++ b/src/Database/Relational/Query/Monad/Trans/Config.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Config --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -20,7 +20,7 @@ import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Control.Applicative (Applicative) -import Database.Relational.Query.Component (Config) +import Database.Relational.Query.Internal.Config (Config) -- | 'ReaderT' type to require query generate configuration. diff --git a/src/Database/Relational/Query/Monad/Trans/Join.hs b/src/Database/Relational/Query/Monad/Trans/Join.hs --- a/src/Database/Relational/Query/Monad/Trans/Join.hs +++ b/src/Database/Relational/Query/Monad/Trans/Join.hs @@ -5,7 +5,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Join --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -33,15 +33,15 @@ import Data.Maybe (fromMaybe) import Data.Monoid (Last (Last, getLast)) +import Database.Relational.Query.Internal.BaseSQL (Duplication (All)) +import Database.Relational.Query.Internal.Product (restrictProduct, growProduct) + +import Database.Relational.Query.Sub (NodeAttr (Just', Maybe), SubQuery, Qualified, JoinProduct, Projection) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Monad.Trans.JoinState (JoinContext, primeJoinContext, updateProduct, joinProduct) -import Database.Relational.Query.Internal.Sub (NodeAttr (Just', Maybe), SubQuery, Qualified, JoinProduct, Projection) -import Database.Relational.Query.Internal.Product (restrictProduct, growProduct) import qualified Database.Relational.Query.Projection as Projection -import Database.Relational.Query.Component (Duplication (All)) import Database.Relational.Query.Projectable (PlaceHolders, unsafeAddPlaceHolders) - import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, untypeRelation) import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadQuery (..)) diff --git a/src/Database/Relational/Query/Monad/Trans/JoinState.hs b/src/Database/Relational/Query/Monad/Trans/JoinState.hs --- a/src/Database/Relational/Query/Monad/Trans/JoinState.hs +++ b/src/Database/Relational/Query/Monad/Trans/JoinState.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.JoinState --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -9,6 +9,8 @@ -- -- This module provides state definition for -- "Database.Relational.Query.Monad.Trans.Join". +-- +-- This is not public interface. module Database.Relational.Query.Monad.Trans.JoinState ( -- * Join context JoinContext, primeJoinContext, updateProduct, joinProduct @@ -17,8 +19,8 @@ import Prelude hiding (product) import Data.DList (toList) -import qualified Database.Relational.Query.Sub as Product -import Database.Relational.Query.Sub (ProductBuilder, JoinProduct) +import Database.Relational.Query.Internal.Sub (ProductBuilder, JoinProduct) +import qualified Database.Relational.Query.Internal.Sub as Product -- | JoinContext type for QueryJoin. diff --git a/src/Database/Relational/Query/Monad/Trans/Ordering.hs b/src/Database/Relational/Query/Monad/Trans/Ordering.hs --- a/src/Database/Relational/Query/Monad/Trans/Ordering.hs +++ b/src/Database/Relational/Query/Monad/Trans/Ordering.hs @@ -5,7 +5,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Ordering --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -16,7 +16,7 @@ -- from query into query with ordering. module Database.Relational.Query.Monad.Trans.Ordering ( -- * Transformer into query with ordering - Orderings, orderings, OrderingTerms, + Orderings, orderings, -- * API of query with ordering orderBy, asc, desc, @@ -31,11 +31,11 @@ import Control.Arrow (second) import Data.DList (DList, toList) -import Database.Relational.Query.Component - (Order(Asc, Desc), OrderColumn, OrderingTerm, OrderingTerms) +import Database.Relational.Query.Internal.BaseSQL + (Order(Asc, Desc), OrderColumn, OrderingTerm) + import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection - import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) @@ -110,5 +110,5 @@ desc = updateOrderBys Desc -- | Run 'Orderings' to get 'OrderingTerms' -extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, OrderingTerms) +extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, [OrderingTerm]) extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc diff --git a/src/Database/Relational/Query/Monad/Trans/Qualify.hs b/src/Database/Relational/Query/Monad/Trans/Qualify.hs --- a/src/Database/Relational/Query/Monad/Trans/Qualify.hs +++ b/src/Database/Relational/Query/Monad/Trans/Qualify.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Qualify --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -10,6 +10,8 @@ -- Portability : unknown -- -- This module defines monad transformer which qualify uniquely SQL table forms. +-- +-- This is not public interface. module Database.Relational.Query.Monad.Trans.Qualify ( -- * Qualify monad Qualify, qualify, @@ -19,17 +21,14 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT, runStateT, get, modify) import Control.Applicative (Applicative) -import Control.Monad (liftM) +import Control.Monad (liftM, ap) -import Database.Relational.Query.Sub (Qualified) -import qualified Database.Relational.Query.Sub as SubQuery +import qualified Database.Relational.Query.Internal.Sub as Internal -type AliasId = Int - -- | Monad type to qualify SQL table forms. newtype Qualify m a = - Qualify (StateT AliasId m a) + Qualify (StateT Int m a) deriving (Monad, Functor, Applicative) -- | Run qualify monad with initial state to get only result. @@ -37,9 +36,9 @@ evalQualifyPrime (Qualify s) = fst `liftM` runStateT s 0 {- primary alias id -} -- | Generated new qualifier on internal state. -newAlias :: Monad m => Qualify m AliasId +newAlias :: Monad m => Qualify m Internal.Qualifier newAlias = Qualify $ do - ai <- get + ai <- Internal.Qualifier `liftM` get modify (+ 1) return ai @@ -49,8 +48,7 @@ -- | Get qualifyed table form query. qualifyQuery :: Monad m - => query -- ^ Query to qualify - -> Qualify m (Qualified query) -- ^ Result with updated state + => query -- ^ Query to qualify + -> Qualify m (Internal.Qualified query) -- ^ Result with updated state qualifyQuery query = - do n <- newAlias - return . SubQuery.qualify query $ SubQuery.Qualifier n + Internal.qualify `liftM` newAlias `ap` return query diff --git a/src/Database/Relational/Query/Monad/Trans/Restricting.hs b/src/Database/Relational/Query/Monad/Trans/Restricting.hs --- a/src/Database/Relational/Query/Monad/Trans/Restricting.hs +++ b/src/Database/Relational/Query/Monad/Trans/Restricting.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Monad.Trans.Restricting --- Copyright : 2014-2016 Kei Hibino +-- Copyright : 2014-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -27,7 +27,6 @@ import Data.DList (DList, toList) import Database.Relational.Query.Sub (QueryRestriction, Projection) - import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) diff --git a/src/Database/Relational/Query/Monad/Type.hs b/src/Database/Relational/Query/Monad/Type.hs --- a/src/Database/Relational/Query/Monad/Type.hs +++ b/src/Database/Relational/Query/Monad/Type.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Monad.Type --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -14,7 +14,8 @@ OrderedQuery, ) where -import Database.Relational.Query.Component (Duplication) +import Database.Relational.Query.Internal.BaseSQL (Duplication) + import Database.Relational.Query.Sub (JoinProduct, QueryRestriction) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) diff --git a/src/Database/Relational/Query/Monad/Unique.hs b/src/Database/Relational/Query/Monad/Unique.hs --- a/src/Database/Relational/Query/Monad/Unique.hs +++ b/src/Database/Relational/Query/Monad/Unique.hs @@ -5,7 +5,7 @@ -- | -- Module : Database.Relational.Query.Monad.Unique --- Copyright : 2014-2016 Kei Hibino +-- Copyright : 2014-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -21,18 +21,17 @@ import Control.Applicative (Applicative) +import Database.Relational.Query.Internal.BaseSQL (Duplication) + import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection - +import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.Class (MonadQualify, MonadQuery) import Database.Relational.Query.Monad.Trans.Join (unsafeSubQueryWithAttr) import Database.Relational.Query.Monad.Trans.Restricting (restrictings) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Query.Monad.Type (QueryCore, extractCore) -import Database.Relational.Query.Projectable (PlaceHolders) - -import Database.Relational.Query.Component (Duplication) import Database.Relational.Query.Sub (SubQuery, QueryRestriction, Qualified, JoinProduct, NodeAttr, flatSubQuery) diff --git a/src/Database/Relational/Query/Pi.hs b/src/Database/Relational/Query/Pi.hs --- a/src/Database/Relational/Query/Pi.hs +++ b/src/Database/Relational/Query/Pi.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Pi --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -23,6 +23,7 @@ import Database.Relational.Query.Pi.Unsafe (Pi, pfmap, pap, (<.>), (), (), definePi) + -- | Identity projection path. id' :: PersistableWidth a => Pi a a diff --git a/src/Database/Relational/Query/Projectable.hs b/src/Database/Relational/Query/Projectable.hs --- a/src/Database/Relational/Query/Projectable.hs +++ b/src/Database/Relational/Query/Projectable.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Relational.Query.Projectable --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -78,13 +78,12 @@ HasColumnConstraint, NotNull) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) -import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow) +import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow) import Database.Relational.Query.Pure (ShowConstantTermsSQL, showConstantTermsSQL', ProductConstructor (..)) import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi as Pi - import Database.Relational.Query.Projection (Projection, ListProjection) import qualified Database.Relational.Query.Projection as Projection diff --git a/src/Database/Relational/Query/Projection.hs b/src/Database/Relational/Query/Projection.hs --- a/src/Database/Relational/Query/Projection.hs +++ b/src/Database/Relational/Query/Projection.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Projection --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -47,20 +47,24 @@ import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint) import qualified Database.Record.KeyConstraint as KeyConstraint -import Database.Relational.Query.Internal.SQL (StringSQL, listStringSQL) +import Database.Relational.Query.Internal.SQL + (StringSQL, listStringSQL, + ColumnSQL, showsColumnSQL, columnSQL', ) import Database.Relational.Query.Internal.Sub - (SubQuery, UntypedProjection, Projection, untypeProjection, typedProjection, Qualified) + (SubQuery, Qualified, UntypedProjection, + Projection, untypeProjection, typedProjection, projectionWidth) +import qualified Database.Relational.Query.Internal.Sub as Internal + import Database.Relational.Query.Context (Aggregated, Flat) -import Database.Relational.Query.Component (ColumnSQL, showsColumnSQL, columnSQL') import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Pure (ProductConstructor (..)) import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Relational.Query.Sub - (widthOfUntypedProjection, projectionColumns, - untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery, - unsafeProjectionStringSql, unsafeProjectFromColumns) + (projectionColumns, + untypedProjectionFromJoinedSubQuery, + unsafeProjectionStringSql) import qualified Database.Relational.Query.Sub as SubQuery @@ -75,7 +79,7 @@ -- | Width of 'Projection'. width :: Projection c r -> Int -width = widthOfUntypedProjection . untypeProjection +width = projectionWidth -- | Unsafely get untyped projection. untype :: Projection c r -> UntypedProjection @@ -88,22 +92,22 @@ -- | Unsafely generate 'Projection' from scalar sub-query. unsafeFromScalarSubQuery :: SubQuery -> Projection c t -unsafeFromScalarSubQuery = typedProjection . untypedProjectionFromScalarSubQuery +unsafeFromScalarSubQuery = Internal.projectFromScalarSubQuery -- | Unsafely generate unqualified 'Projection' from 'Table'. unsafeFromTable :: Table r -> Projection c r -unsafeFromTable = unsafeProjectFromColumns . Table.columns +unsafeFromTable = Internal.projectFromColumns . Table.columns -- | Unsafely generate 'Projection' from SQL expression strings. unsafeFromSqlTerms :: [StringSQL] -> Projection c t -unsafeFromSqlTerms = unsafeProjectFromColumns . map columnSQL' +unsafeFromSqlTerms = Internal.projectFromColumns . map columnSQL' -- | Unsafely trace projection path. unsafeProject :: Projection c a' -> Pi a b -> Projection c b' unsafeProject p pi' = - unsafeProjectFromColumns + Internal.projectFromColumns . (`UnsafePi.pi` pi') . columns $ p diff --git a/src/Database/Relational/Query/Pure.hs b/src/Database/Relational/Query/Pure.hs --- a/src/Database/Relational/Query/Pure.hs +++ b/src/Database/Relational/Query/Pure.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Pure --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -37,6 +37,7 @@ (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) + import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) diff --git a/src/Database/Relational/Query/Relation.hs b/src/Database/Relational/Query/Relation.hs --- a/src/Database/Relational/Query/Relation.hs +++ b/src/Database/Relational/Query/Relation.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Relation --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -42,6 +42,8 @@ import Control.Applicative ((<$>)) +import Database.Relational.Query.Internal.BaseSQL (Duplication (Distinct, All)) + import Database.Relational.Query.Context (Flat, Aggregated) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery, @@ -54,13 +56,9 @@ import qualified Database.Relational.Query.Monad.Aggregate as Aggregate import Database.Relational.Query.Monad.Unique (QueryUnique, unsafeUniqueSubQuery) import qualified Database.Relational.Query.Monad.Unique as Unique - -import Database.Relational.Query.Component (Duplication (Distinct, All)) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) -import Database.Relational.Query.Internal.Sub (NodeAttr(Just', Maybe)) -import Database.Relational.Query.Sub (SubQuery) +import Database.Relational.Query.Sub (SubQuery, NodeAttr(Just', Maybe)) import qualified Database.Relational.Query.Sub as SubQuery - import Database.Relational.Query.Scalar (ScalarDegree) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Projection @@ -148,7 +146,14 @@ aggregateRelation = aggregateRelation' . addUnitPH --- | Restriction function type for direct style join operator. +-- | Restriction predicate function type for direct style join operator, +-- used on predicates of direct join style as follows. +-- +-- @ +-- do xy <- query $ +-- relX `inner` relY `on'` [ \x y -> ... ] -- this lambda form has JoinRestriction type +-- ... +-- @ type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool) -- | Basic direct join operation with place-holder parameters. diff --git a/src/Database/Relational/Query/SQL.hs b/src/Database/Relational/Query/SQL.hs --- a/src/Database/Relational/Query/SQL.hs +++ b/src/Database/Relational/Query/SQL.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.SQL --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -31,13 +31,14 @@ import Language.SQL.Keyword (Keyword(..), (.=.), (|*|)) import qualified Language.SQL.Keyword as SQL - import Database.Record.ToSql (untypedUpdateValuesIndex) -import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowConsStringSQL) +import Database.Relational.Query.Internal.SQL + (StringSQL, stringSQL, showStringSQL, rowConsStringSQL, + ColumnSQL, showsColumnSQL, showsColumnSQL, ) + import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi -import Database.Relational.Query.Component (ColumnSQL, showsColumnSQL, showsColumnSQL) import Database.Relational.Query.Table (Table, name, columns) import qualified Database.Relational.Query.Projection as Projection diff --git a/src/Database/Relational/Query/Scalar.hs b/src/Database/Relational/Query/Scalar.hs --- a/src/Database/Relational/Query/Scalar.hs +++ b/src/Database/Relational/Query/Scalar.hs @@ -3,7 +3,7 @@ -- | -- Module : Database.Relational.Query.Scalar --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -17,6 +17,7 @@ ) where import Language.Haskell.TH (Q, TypeQ, Dec) + import Database.Record (PersistableWidth) diff --git a/src/Database/Relational/Query/Sub.hs b/src/Database/Relational/Query/Sub.hs --- a/src/Database/Relational/Query/Sub.hs +++ b/src/Database/Relational/Query/Sub.hs @@ -2,7 +2,7 @@ -- | -- Module : Database.Relational.Query.Sub --- Copyright : 2013-2016 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -18,22 +18,29 @@ -- * Qualified Sub-query Qualifier (Qualifier), - Qualified, qualifier, unQualify, qualify, + Qualified, queryWidth, + -- deprecated interfaces + qualifier, unQualify, qualify, + -- * Sub-query columns column, -- * Projection Projection, ProjectionUnit, UntypedProjection, - untypedProjectionFromColumns, untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery, - widthOfUntypedProjection, columnsOfUntypedProjection, + untypedProjectionFromJoinedSubQuery, - projectionColumns, unsafeProjectionStringSql, unsafeProjectFromColumns, + projectionColumns, unsafeProjectionStringSql, + -- deprecated interfaces + untypedProjectionFromColumns, untypedProjectionFromScalarSubQuery, + unsafeProjectFromColumns, + widthOfUntypedProjection, columnsOfUntypedProjection, + -- * Product of sub-queries - JoinProduct, NodeAttr, + JoinProduct, NodeAttr (..), nodeTree, ProductBuilder, @@ -42,32 +49,39 @@ composeWhere, composeHaving ) where -import Data.Array (listArray) -import qualified Data.Array as Array +import Control.Applicative ((<$>)) import Data.Monoid (mempty, (<>), mconcat) +import Data.Traversable (traverse) +import Language.SQL.Keyword (Keyword(..), (|*|)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Query.Internal.Config + (Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported)) import qualified Database.Relational.Query.Context as Context -import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, rowStringSQL, showStringSQL) +import Database.Relational.Query.Internal.SQL + (StringSQL, stringSQL, rowStringSQL, showStringSQL, + ColumnSQL, columnSQL', showsColumnSQL, ) +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, untypeProjection, typedProjection, + (SubQuery (..), Projection, UntypedProjection, ProjectionUnit (..), JoinProduct, QueryProductTree, ProductBuilder, - NodeAttr (Just', Maybe), ProductTree (Leaf, Join), Node (Node), + NodeAttr (Just', Maybe), ProductTree (Leaf, Join), Node, SetOp (..), BinOp (..), Qualifier (..), Qualified (..), QueryRestriction) -import Database.Relational.Query.Component - (ColumnSQL, columnSQL', showsColumnSQL, - Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported), - Duplication (..), showsDuplication, - AggregateElem, composeGroupBy, OrderingTerms, composeOrderBy) -import Database.Relational.Query.Table (Table, (!)) +import qualified Database.Relational.Query.Internal.Sub as Internal +import Database.Relational.Query.Internal.UntypedTable ((!)) +import qualified Database.Relational.Query.Internal.UntypedTable as UntypedTable + +import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Pure (showConstantTermsSQL') -import Language.SQL.Keyword (Keyword(..), (|*|)) -import qualified Language.SQL.Keyword as SQL - showsSetOp' :: SetOp -> StringSQL showsSetOp' = d where d Union = UNION @@ -90,7 +104,7 @@ -> Duplication -> JoinProduct -> QueryRestriction Context.Flat - -> OrderingTerms + -> [OrderingTerm] -> SubQuery flatSubQuery = Flat @@ -102,7 +116,7 @@ -> QueryRestriction Context.Flat -> [AggregateElem] -> QueryRestriction Context.Aggregated - -> OrderingTerms + -> [OrderingTerm] -> SubQuery aggregatedSubQuery = Aggregated @@ -124,23 +138,23 @@ -- | Width of 'SubQuery'. width :: SubQuery -> Int width = d where - d (Table u) = Table.width' u + d (Table u) = UntypedTable.width' u d (Bin _ l _) = width l - d (Flat _ up _ _ _ _) = widthOfUntypedProjection up - d (Aggregated _ up _ _ _ _ _ _) = widthOfUntypedProjection up + d (Flat _ up _ _ _ _) = Internal.untypedProjectionWidth up + d (Aggregated _ up _ _ _ _ _ _) = Internal.untypedProjectionWidth up -- | SQL to query table. -fromTableToSQL :: Table.Untyped -> StringSQL +fromTableToSQL :: UntypedTable.Untyped -> StringSQL fromTableToSQL t = - SELECT <> SQL.fold (|*|) [showsColumnSQL c | c <- Table.columns' t] <> - FROM <> stringSQL (Table.name' t) + SELECT <> SQL.fold (|*|) [showsColumnSQL c | c <- UntypedTable.columns' t] <> + FROM <> stringSQL (UntypedTable.name' t) -- | Generate normalized column SQL from table. -fromTableToNormalizedSQL :: Table.Untyped -> StringSQL +fromTableToNormalizedSQL :: UntypedTable.Untyped -> StringSQL fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <> - FROM <> stringSQL (Table.name' t) where + FROM <> stringSQL (UntypedTable.name' t) where columns' = zipWith asColumnN - (Table.columns' t) + (UntypedTable.columns' t) [(0 :: Int)..] -- | Normalized column SQL @@ -159,14 +173,14 @@ selectPrefixSQL up da = SELECT <> showsDuplication da <> SQL.fold (|*|) columns' where columns' = zipWith asColumnN - (columnsOfUntypedProjection up) + (map columnOfProjectionUnit up) [(0 :: Int)..] -- | SQL string for nested-query and toplevel-SQL. toSQLs :: SubQuery -> (StringSQL, StringSQL) -- ^ sub-query SQL and top-level SQL toSQLs = d where - d (Table u) = (stringSQL $ Table.name' u, fromTableToSQL u) + d (Table u) = (stringSQL $ UntypedTable.name' u, fromTableToSQL u) d (Bin (BinOp (op, da)) l r) = (SQL.paren q, q) where q = mconcat [normalizedSQL l, showsSetOp op da, normalizedSQL r] d (Flat cf up da pd rs od) = (SQL.paren q, q) where @@ -191,17 +205,20 @@ 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 (Qualified _ i) = i +qualifier = Internal.qualifier +{-# DEPRECATED unQualify "prepare to drop public interface. use Database.Relational.Query.Internal.Sub.unQualify." #-} -- | Unqualify. unQualify :: Qualified a -> a -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 = Qualified +qualify a q = Internal.qualify q a columnN :: Int -> StringSQL columnN i = stringSQL $ 'f' : show i @@ -215,123 +232,99 @@ -- | Binary operator to qualify. (<.>) :: Qualifier -> ColumnSQL -> ColumnSQL -i <.> n = fmap (showQualifier i SQL.<.>) n +i <.> n = (showQualifier i SQL.<.>) <$> n -- | Qualified expression from qualifier and projection index. columnFromId :: Qualifier -> Int -> ColumnSQL columnFromId qi i = qi <.> columnSQL' (columnN i) --- | From 'Qualified' SQL string into 'String'. +-- | From 'Qualified' SQL string into qualified formed 'String' +-- like (SELECT ...) AS T qualifiedSQLas :: Qualified StringSQL -> StringSQL -qualifiedSQLas q = unQualify q <> showQualifier (qualifier q) +qualifiedSQLas q = Internal.unQualify q <> showQualifier (Internal.qualifier q) -- | Width of 'Qualified' 'SubQUery'. queryWidth :: Qualified SubQuery -> Int -queryWidth = width . unQualify +queryWidth = width . Internal.unQualify -- | Get column SQL string of 'SubQuery'. column :: Qualified SubQuery -> Int -> ColumnSQL -column qs = d (unQualify qs) where - q = qualifier qs +column qs = d (Internal.unQualify qs) where + q = Internal.qualifier qs d (Table u) i = q <.> (u ! i) d (Bin {}) i = q `columnFromId` i d (Flat _ up _ _ _ _) i = columnOfUntypedProjection up i d (Aggregated _ up _ _ _ _ _ _) i = columnOfUntypedProjection up i --- | Get qualified SQL string, like (SELECT ...) AS T0 -qualifiedForm :: Qualified SubQuery -> StringSQL -qualifiedForm = qualifiedSQLas . fmap showUnitSQL - -projectionUnitFromColumns :: [ColumnSQL] -> ProjectionUnit -projectionUnitFromColumns cs = Columns $ listArray (0, length cs - 1) cs - -projectionUnitFromScalarSubQuery :: SubQuery -> ProjectionUnit -projectionUnitFromScalarSubQuery = Scalar - -unitUntypedProjection :: ProjectionUnit -> UntypedProjection -unitUntypedProjection = (:[]) - +{-# DEPRECATED untypedProjectionFromColumns "prepare to drop public interface. use (map RawColumn)." #-} -- | Make untyped projection from columns. untypedProjectionFromColumns :: [ColumnSQL] -> UntypedProjection -untypedProjectionFromColumns = unitUntypedProjection . projectionUnitFromColumns +untypedProjectionFromColumns = map RawColumn +{-# DEPRECATED untypedProjectionFromScalarSubQuery "prepare to drop public interface. use ( (:[]) . Scalar )." #-} -- | Make untyped projection from scalar sub-query. untypedProjectionFromScalarSubQuery :: SubQuery -> UntypedProjection -untypedProjectionFromScalarSubQuery = unitUntypedProjection . projectionUnitFromScalarSubQuery +untypedProjectionFromScalarSubQuery = (:[]) . Scalar -- | Make untyped projection from joined sub-query. untypedProjectionFromJoinedSubQuery :: Qualified SubQuery -> UntypedProjection -untypedProjectionFromJoinedSubQuery qs = d $ unQualify qs where -- unitUntypedProjection . Sub - normalized = unitUntypedProjection . Normalized $ fmap width qs - d (Table _) = untypedProjectionFromColumns . map (column qs) +untypedProjectionFromJoinedSubQuery qs = d $ Internal.unQualify qs where + normalized = SubQueryRef <$> traverse (\q -> [0 .. width q - 1]) qs + d (Table _) = map RawColumn . map (column qs) $ take (queryWidth qs) [0..] d (Bin {}) = normalized d (Flat {}) = normalized d (Aggregated {}) = normalized --- | ProjectionUnit width. -widthOfProjectionUnit :: ProjectionUnit -> Int -widthOfProjectionUnit = d where - d (Columns a) = mx - mn + 1 where (mn, mx) = Array.bounds a - d (Normalized qw) = unQualify qw - d (Scalar _) = 1 - --- | Get column of ProjectionUnit. -columnOfProjectionUnit :: ProjectionUnit -> Int -> ColumnSQL -columnOfProjectionUnit = d where - d (Columns a) i | mn <= i && i <= mx = a Array.! i - | otherwise = error $ "index out of bounds (unit): " ++ show i - where (mn, mx) = Array.bounds a - d (Normalized qw) i | i < w = qualifier qw `columnFromId` i - | otherwise = error $ "index out of bounds (normalized unit): " ++ show i - where w = unQualify qw - d (Scalar sub) 0 = columnSQL' $ showUnitSQL sub - d (Scalar _) i = error $ "index out of bounds (scalar unit): " ++ show i +-- | Convert from ProjectionUnit into column. +columnOfProjectionUnit :: ProjectionUnit -> ColumnSQL +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 = sum . map widthOfProjectionUnit +widthOfUntypedProjection = Internal.untypedProjectionWidth -- | Get column SQL string of 'UntypedProjection'. columnOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection' -> Int -- ^ Column index -> ColumnSQL -- ^ Result SQL string -columnOfUntypedProjection up i' = rec up i' where - rec [] _ = error $ "index out of bounds: " ++ show i' - rec (u : us) i - | i < widthOfProjectionUnit u = columnOfProjectionUnit u i - | i < 0 = error $ "index out of bounds: " ++ show i - | otherwise = rec us (i - widthOfProjectionUnit u) +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 p = map (columnOfUntypedProjection p) . take w $ [0 .. ] - where w = widthOfUntypedProjection p +columnsOfUntypedProjection = map columnOfProjectionUnit -- | Get column SQL string list of projection. projectionColumns :: Projection c r -- ^ Source 'Projection' -> [ColumnSQL] -- ^ Result SQL string list -projectionColumns = columnsOfUntypedProjection . untypeProjection +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 = typedProjection . untypedProjectionFromColumns +unsafeProjectFromColumns = Internal.projectFromColumns --- | Get node attribute. -nodeAttr :: Node rs -> NodeAttr -nodeAttr (Node a _) = a where - +{-# DEPRECATED nodeTree "prepare to drop unused interface. use Database.Relational.Query.Internal.Sub.nodeTree. " #-} -- | Get tree from node. nodeTree :: Node rs -> ProductTree rs -nodeTree (Node _ t) = t +nodeTree = Internal.nodeTree -- | Show product tree of query into SQL. StringSQL result. showsQueryProduct :: QueryProductTree -> StringSQL @@ -343,11 +336,11 @@ urec n = case nodeTree n of p@(Leaf _) -> rec p p@(Join {}) -> SQL.paren (rec p) - rec (Leaf q) = qualifiedForm q + rec (Leaf q) = qualifiedSQLas $ fmap showUnitSQL q rec (Join left' right' rs) = mconcat [urec left', - joinType (nodeAttr left') (nodeAttr right'), JOIN, + joinType (Internal.nodeAttr left') (Internal.nodeAttr right'), JOIN, urec right', ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ] where ps = [ unsafeProjectionStringSql p | p <- rs ] diff --git a/src/Database/Relational/Query/Table.hs b/src/Database/Relational/Query/Table.hs --- a/src/Database/Relational/Query/Table.hs +++ b/src/Database/Relational/Query/Table.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Table --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -10,6 +10,7 @@ -- 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 @@ -19,39 +20,33 @@ TableDerivable (..) ) where -import Data.Array (Array, listArray, elems) -import qualified Data.Array as Array +import Data.Array (listArray) import Database.Record (PersistableWidth) -import Database.Relational.Query.Component (ColumnSQL, columnSQL) +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 -data Untyped = Untyped String Int (Array Int ColumnSQL) deriving Show +type Untyped = Untyped.Untyped -- | Name string of table in SQL name' :: Untyped -> String -name' (Untyped n _ _) = n +name' = Untyped.name' -- | Width of table width' :: Untyped -> Int -width' (Untyped _ w _) = w - --- | Column name strings in SQL -columnArray :: Untyped -> Array Int ColumnSQL -columnArray (Untyped _ _ c) = c +width' = Untyped.width' -- | Column name strings in SQL columns' :: Untyped -> [ColumnSQL] -columns' = elems . columnArray - --- | Column name string in SQL specified by index -(!) :: Untyped - -> Int -- ^ Column index - -> ColumnSQL -- ^ Column name String in SQL -t ! i = columnArray t Array.! i +columns' = Untyped.columns' +-- | Column name strings in SQL +(!) :: Untyped -> Int -> ColumnSQL +(!) = (Untyped.!) -- | Phantom typed table type newtype Table r = Table Untyped @@ -78,7 +73,7 @@ -- | Column name string in SQL specified by index index :: Table r - -> Int -- ^ Column index + -> Int -- ^ Column index -> ColumnSQL -- ^ Column name String in SQL index = (!) . unType @@ -88,7 +83,7 @@ -- | Unsafely generate phantom typed table type. table :: String -> [String] -> Table r -table n f = Table $ Untyped n w fa where +table n f = Table $ Untyped.Untyped n w fa where w = length f fa = listArray (0, w - 1) $ map columnSQL f diff --git a/src/Database/Relational/Query/Type.hs b/src/Database/Relational/Query/Type.hs --- a/src/Database/Relational/Query/Type.hs +++ b/src/Database/Relational/Query/Type.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Query.Type --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -44,7 +44,9 @@ import Database.Record (PersistableWidth) +import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig) import Database.Relational.Query.Internal.SQL (showStringSQL) + import Database.Relational.Query.Monad.BaseType (Relation, sqlFromRelationWith) import Database.Relational.Query.Monad.Restrict (RestrictedStatement) import Database.Relational.Query.Monad.Assign (AssignStatement) @@ -54,7 +56,6 @@ (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget', sqlWhereFromRestriction, sqlFromUpdateTarget, sqlFromInsertTarget) import Database.Relational.Query.Pi (Pi) -import Database.Relational.Query.Component (Config (chunksInsertSize), defaultConfig) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.SQL diff --git a/test/sqlsEq.hs b/test/sqlsEq.hs --- a/test/sqlsEq.hs +++ b/test/sqlsEq.hs @@ -211,6 +211,55 @@ _p_j3s = mapM_ print [show j3left, show j3right] +-- Index of Nested Projections + +nestedPiRec :: Relation () SetA +nestedPiRec = relation $ do + ar <- query . relation $ do + a <- query setA + return $ value "Hello" >< a + return $ ar ! snd' + +nestedPiCol :: Relation () String +nestedPiCol = relation $ do + ar <- query . relation $ do + a <- query setA + return $ a >< value "Hello" + return $ ar ! snd' + +nestedPi :: Relation () String +nestedPi = relation $ do + ar <- query . relation $ do + a <- query setA + return $ (value "Hello" >< a) >< value "World" + return $ ar ! snd' + +nested :: [Test] +nested = + [ eqProp "nested pi record" nestedPiRec + "SELECT ALL T1.f1 AS f0, T1.f2 AS f1, T1.f3 AS f2 \ + \ FROM (SELECT ALL 'Hello' AS f0, \ + \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3 \ + \ FROM TEST.set_a T0) T1" + + , eqProp "nested pi column" nestedPiCol + "SELECT ALL T1.f3 AS f0 \ + \ FROM (SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ + \ 'Hello' AS f3 \ + \ FROM TEST.set_a T0) T1" + + , eqProp "nested pi both" nestedPi + "SELECT ALL T1.f4 AS f0 \ + \ FROM (SELECT ALL 'Hello' AS f0, \ + \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3, \ + \ 'World' AS f4 \ + \ FROM TEST.set_a T0) T1" + ] + +_p_nested :: IO () +_p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] + + -- Projection Operators bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r @@ -581,7 +630,7 @@ tests :: [Test] tests = - concat [ tables, monadic, directJoins, join3s, bin, uni + concat [ tables, monadic, directJoins, join3s, nested, bin, uni , groups, orders, partitions, exps, effs, correlated] main :: IO () diff --git a/test/sqlsEqArrow.hs b/test/sqlsEqArrow.hs --- a/test/sqlsEqArrow.hs +++ b/test/sqlsEqArrow.hs @@ -129,6 +129,52 @@ _p_j3s :: IO () _p_j3s = mapM_ print [show j3left, show j3right] +nestedPiRec :: Relation () SetA +nestedPiRec = relation $ proc () -> do + ar <- (query . relation $ proc () -> do + a <- query setA -< () + returnA -< value "Hello" >< a) -< () + returnA -< ar ! snd' + +nestedPiCol :: Relation () String +nestedPiCol = relation $ proc () -> do + ar <- (query . relation $ proc () -> do + a <- query setA -< () + returnA -< a >< value "Hello") -< () + returnA -< ar ! snd' + +nestedPi :: Relation () String +nestedPi = relation $ proc () -> do + ar <- (query . relation $ proc () -> do + a <- query setA -< () + returnA -< (value "Hello" >< a) >< value "World") -< () + returnA -< ar ! snd' + +nested :: [Test] +nested = + [ eqProp "nested pi record" nestedPiRec + "SELECT ALL T1.f1 AS f0, T1.f2 AS f1, T1.f3 AS f2 \ + \ FROM (SELECT ALL 'Hello' AS f0, \ + \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3 \ + \ FROM TEST.set_a T0) T1" + + , eqProp "nested pi column" nestedPiCol + "SELECT ALL T1.f3 AS f0 \ + \ FROM (SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ + \ 'Hello' AS f3 \ + \ FROM TEST.set_a T0) T1" + + , eqProp "nested pi both" nestedPi + "SELECT ALL T1.f4 AS f0 \ + \ FROM (SELECT ALL 'Hello' AS f0, \ + \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3, \ + \ 'World' AS f4 \ + \ FROM TEST.set_a T0) T1" + ] + +_p_nested :: IO () +_p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] + justX :: Relation () (SetA, Maybe SetB) justX = relation $ proc () -> do a <- query setA -< () @@ -357,7 +403,7 @@ tests :: [Test] tests = - concat [ bin, tables, directJoins, join3s, maybes + concat [ bin, tables, directJoins, join3s, nested, maybes , groups, orders, partitions, exps, effs] main :: IO ()