relational-query-0.8.3.2/0000755000000000000000000000000013000574776013356 5ustar0000000000000000relational-query-0.8.3.2/ChangeLog.md0000644000000000000000000000462513000574776015536 0ustar0000000000000000 ## 0.8.3.2 - Export Register interface type from Query module. ## 0.8.3.1 - Refactor around sub-query and its builder. - Compatibility with dlist-0.5. ## 0.8.3.0 - Add configuration to quote SQL string of table names. ## 0.8.2.3 - Add tested-with meta-data. ## 0.8.2.2 - Update for GHC 8. ## 0.8.2.1 - Fix constraint of build-depends. ## 0.8.2.0 - Add TIMESTAMPTZ literal of PostgreSQL. ## 0.8.1.0 - Add schemaNameMode configuration. ## 0.8.0.5 - Update tests along with deprecations. ## 0.8.0.4 - Drop unused pragma. ## 0.8.0.3 - Drop unreferenced overloading. ## 0.8.0.2 - Update documentation. ## 0.8.0.1 - Fix build-depends. ## 0.8.0.0 - Drop unsafe Expr type. - Drop redundant type synonyms around DELETE and UPDATE. - Add Register monad to add build-able INSERT statement - Configurable relation template names. ## 0.7.1.0 - Deprecate redundant type synonyms. ## 0.7.0.2 - Prepare to drop Expr type and deprecate around it. - Fix boolean projection operator types. ## 0.7.0.1 - Update this changelog. ## 0.7.0.0 - Use TH quotations for deriving class symbols. ## 0.6.4.0 - Fix around correlated sub-queries. - Update unit-test cases. ## 0.6.3.0 - Add Int8 type as SQL constant int value. (e.g. MySQL) ## 0.6.2.0 - Make InsertQuery type as PreparedNoFetch instance. ## 0.6.1.0 - Add a configuration flag to pring verbose compile-time messages. ## 0.6.0.0 - Increase type safety of interfaces. - Simplify interfaces arond unique query. ## 0.5.2.0 - Add MonadTrans instance of QueryJoin. - Update links about Opaleye. ## 0.5.1.1 - Update documentation. ## 0.5.1.0 - Add the arrow combinator module and its unit-test cases. ## 0.5.0.3 - Update unit-test cases. - Add the fixity of `over` operator. - Avoid an `a future Prelude name' warning. ## 0.5.0.2 - Switch libraries to use from test-suites not to depend on Cabal library. ## 0.5.0.1 - Add this ChangeLog file. ## 0.5.0.0 - Prevent window function context expression from using normal SQL expressions. - Generalize the result types of aggregate and window functions. - Allow to embed a integer literal in SQL from Haskell Int type. - Add SQL LIKE operators. - Drop old deprecated functions. (fromMaybe', dense_rank, ...) - Fix typo. https://github.com/khibino/haskell-relational-record/pull/15 - Fix for "invalid single-column insert syntax". https://github.com/khibino/haskell-relational-record/issues/16 relational-query-0.8.3.2/LICENSE0000644000000000000000000000275613000574776014375 0ustar0000000000000000Copyright (c) 2013, Kei Hibino All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Kei Hibino nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. relational-query-0.8.3.2/Setup.hs0000644000000000000000000000005613000574776015013 0ustar0000000000000000import Distribution.Simple main = defaultMain relational-query-0.8.3.2/relational-query.cabal0000644000000000000000000001260013000574776017636 0ustar0000000000000000name: relational-query version: 0.8.3.2 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can translate into SQL query. Supported query features are below: - Type safe query building - Restriction, Join, Aggregation - Modularized relations - Typed placeholders homepage: http://khibino.github.io/haskell-relational-record/ license: BSD3 license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com copyright: Copyright (c) 2013-2016 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.0.1 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 extra-source-files: ChangeLog.md library exposed-modules: Database.Relational.Query.Arrow Database.Relational.Query Database.Relational.Query.Table Database.Relational.Query.SQL Database.Relational.Query.Pure Database.Relational.Query.Pi Database.Relational.Query.Pi.Unsafe Database.Relational.Query.Constraint Database.Relational.Query.Context Database.Relational.Query.Projectable Database.Relational.Query.ProjectableExtended Database.Relational.Query.Component Database.Relational.Query.Sub Database.Relational.Query.Projection Database.Relational.Query.Monad.BaseType Database.Relational.Query.Monad.Class Database.Relational.Query.Monad.Trans.Ordering Database.Relational.Query.Monad.Trans.Aggregating Database.Relational.Query.Monad.Trans.Restricting Database.Relational.Query.Monad.Trans.Join Database.Relational.Query.Monad.Trans.Config Database.Relational.Query.Monad.Trans.Assigning Database.Relational.Query.Monad.Type Database.Relational.Query.Monad.Simple Database.Relational.Query.Monad.Aggregate Database.Relational.Query.Monad.Unique Database.Relational.Query.Monad.Restrict Database.Relational.Query.Monad.Assign Database.Relational.Query.Monad.Register Database.Relational.Query.Relation Database.Relational.Query.Effect Database.Relational.Query.Scalar Database.Relational.Query.Type Database.Relational.Query.Derives Database.Relational.Query.TH other-modules: Database.Relational.Query.Internal.SQL Database.Relational.Query.Internal.Product Database.Relational.Query.Internal.Sub Database.Relational.Query.Monad.Trans.JoinState Database.Relational.Query.Monad.Trans.Qualify build-depends: base <5 , array , containers , transformers , time , time-locale-compat , bytestring , text , dlist , template-haskell , th-reify-compat , sql-words >=0.1.4 , names-th , persistable-record >= 0.3 hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 test-suite sqls build-depends: base <5 , quickcheck-simple , relational-query , containers , transformers type: exitcode-stdio-1.0 main-is: sqlsEq.hs other-modules: Lex Model hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 test-suite sqlsArrow build-depends: base <5 , quickcheck-simple , relational-query , containers , transformers type: exitcode-stdio-1.0 main-is: sqlsEqArrow.hs other-modules: Lex Model hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 source-repository head type: git location: https://github.com/khibino/haskell-relational-record source-repository head type: mercurial location: https://bitbucket.org/khibino/haskell-relational-record relational-query-0.8.3.2/src/0000755000000000000000000000000013000574776014145 5ustar0000000000000000relational-query-0.8.3.2/src/Database/0000755000000000000000000000000013000574776015651 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/0000755000000000000000000000000013000574776017743 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/Query.hs0000644000000000000000000000754713000574776021421 0ustar0000000000000000-- | -- Module : Database.Relational.Query -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module is integrated module of Query. module Database.Relational.Query ( module Database.Relational.Query.Table, module Database.Relational.Query.SQL, module Database.Relational.Query.Pure, module Database.Relational.Query.Pi, module Database.Relational.Query.Constraint, module Database.Relational.Query.Context, module Database.Relational.Query.Component, module Database.Relational.Query.Sub, module Database.Relational.Query.Projection, module Database.Relational.Query.Projectable, module Database.Relational.Query.ProjectableExtended, module Database.Relational.Query.Monad.Class, module Database.Relational.Query.Monad.Trans.Aggregating, module Database.Relational.Query.Monad.Trans.Ordering, module Database.Relational.Query.Monad.Trans.Assigning, module Database.Relational.Query.Monad.BaseType, module Database.Relational.Query.Monad.Type, module Database.Relational.Query.Monad.Simple, module Database.Relational.Query.Monad.Aggregate, module Database.Relational.Query.Monad.Restrict, module Database.Relational.Query.Monad.Unique, module Database.Relational.Query.Monad.Assign, module Database.Relational.Query.Monad.Register, module Database.Relational.Query.Relation, module Database.Relational.Query.Scalar, module Database.Relational.Query.Type, module Database.Relational.Query.Effect, module Database.Relational.Query.Derives ) where import Database.Relational.Query.Table (Table, TableDerivable (..)) import Database.Relational.Query.SQL (updateOtherThanKeySQL, insertSQL) import Database.Relational.Query.Pure import Database.Relational.Query.Pi import Database.Relational.Query.Constraint (Key, tableConstraint, projectionKey, uniqueKey, -- notNullKey, HasConstraintKey(constraintKey), derivedUniqueKey, -- derivedNotNullKey, Primary, Unique, NotNull) import Database.Relational.Query.Context import Database.Relational.Query.Component (NameConfig (..), SchemaNameMode (..), Config (..), defaultConfig, ProductUnitSupport (..), IdentifierQuotation (..), Order (..)) import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth) import Database.Relational.Query.Projection (Projection, list) import Database.Relational.Query.Projectable import Database.Relational.Query.ProjectableExtended import Database.Relational.Query.Monad.Class (MonadQualify, MonadRestrict, wheres, having, restrict, MonadAggregate, groupBy, groupBy', MonadQuery, query', queryMaybe', MonadPartition, partitionBy, distinct, all', on) import Database.Relational.Query.Monad.Trans.Aggregating (key, key', set, bkey, rollup, cube, groupingSets) import Database.Relational.Query.Monad.Trans.Ordering (orderBy, asc, desc) import Database.Relational.Query.Monad.Trans.Assigning (assignTo, (<-#)) import Database.Relational.Query.Monad.BaseType import Database.Relational.Query.Monad.Type import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery, Window, over) import Database.Relational.Query.Monad.Restrict (Restrict) import Database.Relational.Query.Monad.Unique (QueryUnique) import Database.Relational.Query.Monad.Assign (Assign) import Database.Relational.Query.Monad.Register (Register) import Database.Relational.Query.Relation import Database.Relational.Query.Scalar (ScalarDegree) import Database.Relational.Query.Type hiding (unsafeTypedQuery, unsafeTypedKeyUpdate, unsafeTypedUpdate, unsafeTypedInsert, unsafeTypedInsertQuery, unsafeTypedDelete) import Database.Relational.Query.Effect import Database.Relational.Query.Derives import Database.Record.Instances () {-# ANN module "HLint: ignore Use import/export shortcut" #-} relational-query-0.8.3.2/src/Database/Relational/Query/0000755000000000000000000000000013000574776021050 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/Query/Component.hs0000644000000000000000000002245513000574776023356 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Component -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides untyped components for query. module Database.Relational.Query.Component ( -- * Type for column SQL string ColumnSQL, columnSQL, columnSQL', showsColumnSQL, -- * Configuration type for query NameConfig (..), SchemaNameMode (..), Config ( productUnitSupport , chunksInsertSize , schemaNameMode , normalizedTableName , verboseAsCompilerWarning , nameConfig , identifierQuotation), defaultConfig, ProductUnitSupport (..), Duplication (..), IdentifierQuotation (..), -- * Duplication attribute showsDuplication, -- * Types for aggregation AggregateColumnRef, AggregateBitKey, AggregateSet, AggregateElem, aggregateColumnRef, aggregateEmpty, aggregatePowerKey, aggregateGroupingSet, aggregateRollup, aggregateCube, aggregateSets, composeGroupBy, composePartitionBy, AggregateKey, aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey, -- * Types for ordering Order (..), OrderColumn, OrderingTerm, OrderingTerms, composeOrderBy, -- * Types for assignments AssignColumn, AssignTerm, Assignment, Assignments, composeSets, composeValues, -- * 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 qualified Language.SQL.Keyword as SQL import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) import qualified Database.Record.TH as RecordTH -- | 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 -- | String from ColumnSQL stringFromColumnSQL :: ColumnSQL -> String stringFromColumnSQL = showStringSQL . showsColumnSQL -- | StringSQL from ColumnSQL showsColumnSQL :: ColumnSQL -> StringSQL showsColumnSQL (ColumnSQL c) = c instance Show ColumnSQL where show = stringFromColumnSQL -- | 'NameConfig' type to customize names of expanded templates. data NameConfig = NameConfig { recordConfig :: RecordTH.NameConfig , relationVarName :: String -> String -> VarName } 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 -- | 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 -- | 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 -- | 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) -- | Typeful aggregate element. newtype AggregateKey a = AggregateKey (a, AggregateElem) -- | 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 -- | 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) -- | Type for order-by terms type OrderingTerms = [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 -- | Column SQL String type AssignColumn = ColumnSQL -- | Value SQL String type AssignTerm = ColumnSQL -- | Assignment pair type Assignment = (AssignColumn, AssignTerm) -- | Assignment pair list. type Assignments = [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 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 /OVER (PARTITION BY ... )/ clause. composeOver :: [AggregateColumnRef] -> OrderingTerms -> StringSQL composeOver pts ots = OVER <> SQL.paren (composePartitionBy pts <> composeOrderBy ots) relational-query-0.8.3.2/src/Database/Relational/Query/Table.hs0000644000000000000000000000472413000574776022442 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Table -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines table type which has table metadatas. module Database.Relational.Query.Table ( -- * Untyped table type Untyped, name', width', columns', (!), -- * Phantom typed table type Table, unType, name, shortName, width, columns, index, table, toMaybe, -- * Table existence inference TableDerivable (..) ) where import Data.Array (Array, listArray, elems) import qualified Data.Array as Array import Database.Record (PersistableWidth) import Database.Relational.Query.Component (ColumnSQL, 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 -- | Phantom typed table type newtype Table r = Table Untyped -- | Untype table. unType :: Table t -> Untyped unType (Table u) = u -- | Name string of table in SQL name :: Table r -> String name = name' . unType -- | Not qualified name string of table in SQL shortName :: Table r -> String shortName = tail . dropWhile (/= '.') . name -- | Width of table width :: Table r -> Int width = width' . unType -- | Column name strings in SQL columns :: Table r -> [ColumnSQL] columns = columns' . unType -- | Column name string in SQL specified by index index :: Table r -> Int -- ^ Column index -> ColumnSQL -- ^ Column name String in SQL index = (!) . unType -- | Cast phantom type into 'Maybe' type. toMaybe :: Table r -> Table (Maybe r) toMaybe (Table t) = Table t -- | Unsafely generate phantom typed table type. table :: String -> [String] -> Table r table n f = Table $ Untyped n w fa where w = length f fa = listArray (0, w - 1) $ map columnSQL f -- | Inference rule of 'Table' existence. class PersistableWidth r => TableDerivable r where derivedTable :: Table r relational-query-0.8.3.2/src/Database/Relational/Query/Constraint.hs0000644000000000000000000000773413000574776023543 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Constraint -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides proof object definitions of constraint key. -- Difference between this module and "Database.Record.KeyConstraint" is -- typed constraint key column definition is included in this module. module Database.Relational.Query.Constraint ( -- * Constraint Key proof object Key, indexes, unsafeDefineConstraintKey, tableConstraint, projectionKey, -- unsafeReturnKey, -- unsafeAppendConstraint, -- * Derivation rules uniqueKey, -- notNullKey, -- * Inference rules HasConstraintKey (..), derivedUniqueKey, -- derivedNotNullKey, -- * Constraint types Primary, Unique, NotNull ) where import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Record.KeyConstraint (KeyConstraint, unsafeSpecifyKeyConstraint, Primary, Unique, NotNull) import qualified Database.Record.KeyConstraint as C import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) -- | Constraint Key proof object. Constraint type 'c', record type 'r' and columns type 'ct'. data Key c r ct = Key [Int] (PersistableRecordWidth ct) -- | Index of key which specifies constraint key. indexes :: Key c r ct -> [Int] indexes (Key is _) = is -- | Width of key. width :: Key c r ct -> PersistableRecordWidth ct width (Key _ w) = w -- | Unsafely generate constraint 'Key' proof object using specified key index. unsafeDefineConstraintKey :: PersistableWidth ct => [Int] -- ^ Key indexes which specify this constraint key -> Key c r ct -- ^ Result constraint key proof object unsafeDefineConstraintKey ixs = Key ixs persistableWidth -- | Get table constraint 'KeyConstraint' proof object from constraint 'Key'. tableConstraint :: Key c r ct -> KeyConstraint c r tableConstraint = unsafeSpecifyKeyConstraint . indexes -- | Get projection path proof object from constraint 'Key'. projectionKey :: Key c r ct -> Pi r ct projectionKey k = UnsafePi.defineDirectPi' w ixs where ixs = indexes k w = width k -- | Unsafe. Make constraint key to add column phantom type unsafeReturnKey :: PersistableWidth ct => KeyConstraint c r -> Key c r ct unsafeReturnKey = unsafeDefineConstraintKey . C.indexes -- -- | Unsafe. Make constraint key to add constraint phantom type -- unsafeAppendConstraint :: Pi r ct -> Key c r ct -- unsafeAppendConstraint = unsafeDefineConstraintKey . leafIndex -- | Map from table constraint into constraint 'Key'. mapConstraint :: PersistableWidth ct => (KeyConstraint c0 r -> KeyConstraint c1 r) -> Key c0 r ct -> Key c1 r ct mapConstraint f = unsafeReturnKey . f . tableConstraint -- | Derive 'Unique' constraint 'Key' from 'Primary' constraint 'Key' uniqueKey :: PersistableWidth ct => Key Primary r ct -> Key Unique r ct uniqueKey = mapConstraint C.unique -- -- | Derive 'NotNull' constraint 'Key' from 'Primary' constraint 'Key' -- notNullKey :: Key Primary r ct -> Key NotNull r ct -- notNullKey = mapConstraint C.notNull -- | Constraint 'Key' inference interface. class PersistableWidth ct => HasConstraintKey c r ct where -- | Infer constraint key. constraintKey :: Key c r ct -- | Infered 'Unique' constraint 'Key'. -- Record type 'r' has unique key which type is 'ct' derived from primay key. derivedUniqueKey :: HasConstraintKey Primary r ct => Key Unique r ct derivedUniqueKey = uniqueKey constraintKey -- -- | Infered 'NotNull' constraint 'Key'. -- -- Record type 'r' has not-null key which type is 'ct' derived from primay key. -- derivedNotNullKey :: HasConstraintKey Primary r ct => Key NotNull r ct -- derivedNotNullKey = notNullKey constraintKey relational-query-0.8.3.2/src/Database/Relational/Query/SQL.hs0000644000000000000000000001156413000574776022052 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Query.SQL -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines functions to generate simple SQL strings. module Database.Relational.Query.SQL ( -- * Query suffix QuerySuffix, showsQuerySuffix, -- * Update SQL updatePrefixSQL, updateSQL', updateOtherThanKeySQL', updateOtherThanKeySQL, -- * Insert SQL insertPrefixSQL, insertSQL, insertSizedChunkSQL, -- * Delete SQL deletePrefixSQL', deletePrefixSQL ) where import Data.Array (listArray, (!)) import Data.Monoid (mconcat, (<>)) 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.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 -- | Type for query suffix words type QuerySuffix = [Keyword] -- | Expand query suffix words showsQuerySuffix :: QuerySuffix -> StringSQL showsQuerySuffix = mconcat -- | Generate prefix string of update SQL. updatePrefixSQL :: Table r -> StringSQL updatePrefixSQL table = UPDATE <> stringSQL (name table) -- | Generate update SQL by specified key and table. -- Columns name list of table are also required. updateSQL' :: String -- ^ Table name -> [ColumnSQL] -- ^ Column name list to update -> [ColumnSQL] -- ^ Key column name list -> String -- ^ Result SQL updateSQL' table cols key = showStringSQL $ mconcat [UPDATE, stringSQL table, SET, SQL.fold (|*|) updAssigns, WHERE, SQL.fold SQL.and keyAssigns] where assigns cs = [ showsColumnSQL c .=. "?" | c <- cs ] updAssigns = assigns cols keyAssigns = assigns key -- | Generate update SQL by specified key and table. -- Columns name list of table are also required. updateOtherThanKeySQL' :: String -- ^ Table name -> [ColumnSQL] -- ^ Column name list -> [Int] -- ^ Key column indexes -> String -- ^ Result SQL updateOtherThanKeySQL' table cols ixs = updateSQL' table updColumns keyColumns where width' = length cols cols' = listArray (0, width' -1) cols otherThanKey = untypedUpdateValuesIndex ixs width' columns' is = [ cols' ! i | i <- is ] updColumns = columns' otherThanKey keyColumns = columns' ixs -- | Generate update SQL specified by single key. updateOtherThanKeySQL :: Table r -- ^ Table metadata -> Pi r p -- ^ Key columns -> String -- ^ Result SQL updateOtherThanKeySQL tbl key = updateOtherThanKeySQL' (name tbl) (columns tbl) (UnsafePi.unsafeExpandIndexes key) -- | Generate prefix string of insert SQL. insertPrefixSQL :: Pi r r' -> Table r -> StringSQL insertPrefixSQL pi' table = INSERT <> INTO <> stringSQL (name table) <> rowConsStringSQL [showsColumnSQL c | c <- cols] where cols = Projection.columns . Projection.pi (Projection.unsafeFromTable table) $ pi' -- | Generate records chunk insert SQL. insertChunkSQL :: Int -- ^ Records count to insert -> Pi r r' -- ^ Columns selector to insert -> Table r -- ^ Table metadata -> String -- ^ Result SQL insertChunkSQL n0 pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs where n | n0 >= 1 = n0 | otherwise = error $ "Invalid chunk count value: " ++ show n0 w = UnsafePi.width pi' vs = SQL.fold (|*|) . replicate n $ rowConsStringSQL (replicate w "?") -- | Generate size measured records chunk insert SQL. insertSizedChunkSQL :: Pi r r' -- ^ Columns selector to insert -> Table r -- ^ Table metadata -> Int -- ^ Chunk size threshold (column count) -> (String, Int) -- ^ Result SQL and records count of chunk insertSizedChunkSQL pi' tbl th = (insertChunkSQL n pi' tbl, n) where w = UnsafePi.width pi' n = th `quot` w + 1 -- | Generate insert SQL. insertSQL :: Pi r r' -- ^ Columns selector to insert -> Table r -- ^ Table metadata -> String -- ^ Result SQL insertSQL = insertChunkSQL 1 -- | Generate all column delete SQL by specified table. Untyped table version. deletePrefixSQL' :: String -> StringSQL deletePrefixSQL' table = DELETE <> FROM <> stringSQL table -- | Generate all column delete SQL by specified table. deletePrefixSQL :: Table r -- ^ Table metadata -> StringSQL -- ^ Result SQL deletePrefixSQL = deletePrefixSQL' . name relational-query-0.8.3.2/src/Database/Relational/Query/Scalar.hs0000644000000000000000000000153013000574776022610 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Scalar -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines type classes and templates for scalar queries. module Database.Relational.Query.Scalar ( -- * Single degree constraint ScalarDegree, defineScalarDegree ) where import Language.Haskell.TH (Q, TypeQ, Dec) import Database.Record (PersistableWidth) -- | Constraint which represents scalar degree. class PersistableWidth ct => ScalarDegree ct instance ScalarDegree ct => ScalarDegree (Maybe ct) -- | 'ScalarDegree' instance templates. defineScalarDegree :: TypeQ -> Q [Dec] defineScalarDegree typeCon = do [d| instance ScalarDegree $(typeCon) |] relational-query-0.8.3.2/src/Database/Relational/Query/Sub.hs0000644000000000000000000003333213000574776022141 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Query.Sub -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines sub-query structure used in query products. module Database.Relational.Query.Sub ( -- * Sub-query SubQuery, fromTable, flatSubQuery, aggregatedSubQuery, union, except, intersect, showSQL, toSQL, unitSQL, width, -- * Qualified Sub-query Qualifier (Qualifier), Qualified, qualifier, unQualify, qualify, queryWidth, -- * Sub-query columns column, -- * Projection Projection, ProjectionUnit, UntypedProjection, untypedProjectionFromColumns, untypedProjectionFromJoinedSubQuery, untypedProjectionFromScalarSubQuery, widthOfUntypedProjection, columnsOfUntypedProjection, projectionColumns, unsafeProjectionStringSql, unsafeProjectFromColumns, -- * Product of sub-queries JoinProduct, NodeAttr, nodeTree, ProductBuilder, -- * Query restriction QueryRestriction, composeWhere, composeHaving ) where import Data.Array (listArray) import qualified Data.Array as Array import Data.Monoid (mempty, (<>), mconcat) import qualified Database.Relational.Query.Context as Context import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, rowStringSQL, showStringSQL) import Database.Relational.Query.Internal.Sub (SubQuery (..), Projection, untypeProjection, typedProjection, UntypedProjection, ProjectionUnit (..), JoinProduct, QueryProductTree, ProductBuilder, NodeAttr (Just', Maybe), ProductTree (Leaf, Join), Node (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.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 d Except = EXCEPT d Intersect = INTERSECT showsSetOp :: SetOp -> Duplication -> StringSQL showsSetOp op dup0 = showsSetOp' op <> mayDup dup0 where mayDup dup@All = showsDuplication dup mayDup Distinct = mempty -- | 'SubQuery' from 'Table'. fromTable :: Table r -- ^ Typed 'Table' metadata -> SubQuery -- ^ Result 'SubQuery' fromTable = Table . Table.unType -- | Unsafely generate flat 'SubQuery' from untyped components. flatSubQuery :: Config -> UntypedProjection -> Duplication -> JoinProduct -> QueryRestriction Context.Flat -> OrderingTerms -> SubQuery flatSubQuery = Flat -- | Unsafely generate aggregated 'SubQuery' from untyped components. aggregatedSubQuery :: Config -> UntypedProjection -> Duplication -> JoinProduct -> QueryRestriction Context.Flat -> [AggregateElem] -> QueryRestriction Context.Aggregated -> OrderingTerms -> SubQuery aggregatedSubQuery = Aggregated setBin :: SetOp -> Duplication -> SubQuery -> SubQuery -> SubQuery setBin op = Bin . BinOp . (,) op -- | Union binary operator on 'SubQuery' union :: Duplication -> SubQuery -> SubQuery -> SubQuery union = setBin Union -- | Except binary operator on 'SubQuery' except :: Duplication -> SubQuery -> SubQuery -> SubQuery except = setBin Except -- | Intersect binary operator on 'SubQuery' intersect :: Duplication -> SubQuery -> SubQuery -> SubQuery intersect = setBin Intersect -- | Width of 'SubQuery'. width :: SubQuery -> Int width = d where d (Table u) = Table.width' u d (Bin _ l _) = width l d (Flat _ up _ _ _ _) = widthOfUntypedProjection up d (Aggregated _ up _ _ _ _ _ _) = widthOfUntypedProjection up -- | SQL to query table. fromTableToSQL :: Table.Untyped -> StringSQL fromTableToSQL t = SELECT <> SQL.fold (|*|) [showsColumnSQL c | c <- Table.columns' t] <> FROM <> stringSQL (Table.name' t) -- | Generate normalized column SQL from table. fromTableToNormalizedSQL :: Table.Untyped -> StringSQL fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <> FROM <> stringSQL (Table.name' t) where columns' = zipWith asColumnN (Table.columns' t) [(0 :: Int)..] -- | Normalized column SQL normalizedSQL :: SubQuery -> StringSQL normalizedSQL = d where d (Table t) = fromTableToNormalizedSQL t d sub@(Bin {}) = showUnitSQL sub d sub@(Flat _ _ _ _ _ ots) | null ots = showSQL sub | otherwise = showUnitSQL sub d sub@(Aggregated _ _ _ _ _ _ _ ots) | null ots = showSQL sub | otherwise = showUnitSQL sub selectPrefixSQL :: UntypedProjection -> Duplication -> StringSQL selectPrefixSQL up da = SELECT <> showsDuplication da <> SQL.fold (|*|) columns' where columns' = zipWith asColumnN (columnsOfUntypedProjection 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 (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 q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs <> composeOrderBy od d (Aggregated cf up da pd rs ag grs od) = (SQL.paren q, q) where q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs <> composeGroupBy ag <> composeHaving grs <> composeOrderBy od showUnitSQL :: SubQuery -> StringSQL showUnitSQL = fst . toSQLs -- | SQL string for nested-qeury. unitSQL :: SubQuery -> String unitSQL = showStringSQL . showUnitSQL -- | SQL StringSQL for toplevel-SQL. showSQL :: SubQuery -> StringSQL showSQL = snd . toSQLs -- | SQL string for toplevel-SQL. toSQL :: SubQuery -> String toSQL = showStringSQL . showSQL -- | Get qualifier qualifier :: Qualified a -> Qualifier qualifier (Qualified _ i) = i -- | Unqualify. unQualify :: Qualified a -> a unQualify (Qualified a _) = a -- | Add qualifier qualify :: a -> Qualifier -> Qualified a qualify = Qualified columnN :: Int -> StringSQL columnN i = stringSQL $ 'f' : show i asColumnN :: ColumnSQL -> Int -> StringSQL c `asColumnN` n = showsColumnSQL c `SQL.as` columnN n -- | Alias string from qualifier showQualifier :: Qualifier -> StringSQL showQualifier (Qualifier i) = stringSQL $ 'T' : show i -- | Binary operator to qualify. (<.>) :: Qualifier -> ColumnSQL -> ColumnSQL i <.> n = fmap (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'. qualifiedSQLas :: Qualified StringSQL -> StringSQL qualifiedSQLas q = unQualify q <> showQualifier (qualifier q) -- | Width of 'Qualified' 'SubQUery'. queryWidth :: Qualified SubQuery -> Int queryWidth = width . unQualify -- | Get column SQL string of 'SubQuery'. column :: Qualified SubQuery -> Int -> ColumnSQL column qs = d (unQualify qs) where q = 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 = (:[]) -- | Make untyped projection from columns. untypedProjectionFromColumns :: [ColumnSQL] -> UntypedProjection untypedProjectionFromColumns = unitUntypedProjection . projectionUnitFromColumns -- | Make untyped projection from scalar sub-query. untypedProjectionFromScalarSubQuery :: SubQuery -> UntypedProjection untypedProjectionFromScalarSubQuery = unitUntypedProjection . projectionUnitFromScalarSubQuery -- | 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) $ 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 -- | Width of 'UntypedProjection'. widthOfUntypedProjection :: UntypedProjection -> Int widthOfUntypedProjection = sum . map widthOfProjectionUnit -- | 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) -- | 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 -- | Get column SQL string list of projection. projectionColumns :: Projection c r -- ^ Source 'Projection' -> [ColumnSQL] -- ^ Result SQL string list projectionColumns = columnsOfUntypedProjection . untypeProjection -- | Unsafely get SQL term from 'Proejction'. unsafeProjectionStringSql :: Projection c r -> StringSQL unsafeProjectionStringSql = rowStringSQL . map showsColumnSQL . projectionColumns -- | Unsafely generate 'Projection' from SQL string list. unsafeProjectFromColumns :: [ColumnSQL] -- ^ SQL string list specifies columns -> Projection c r -- ^ Result 'Projection' unsafeProjectFromColumns = typedProjection . untypedProjectionFromColumns -- | 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 -- | Show product tree of query into SQL. StringSQL result. showsQueryProduct :: QueryProductTree -> StringSQL showsQueryProduct = rec where joinType Just' Just' = INNER joinType Just' Maybe = LEFT joinType Maybe Just' = RIGHT joinType Maybe Maybe = FULL urec n = case nodeTree n of p@(Leaf _) -> rec p p@(Join {}) -> SQL.paren (rec p) rec (Leaf q) = qualifiedForm q rec (Join left' right' rs) = mconcat [urec left', joinType (nodeAttr left') (nodeAttr right'), JOIN, urec right', ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL' True | null ps ] ] where ps = [ unsafeProjectionStringSql p | p <- rs ] -- | Shows join product of query. showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL showsJoinProduct ups = maybe (up ups) from where from qp = FROM <> showsQueryProduct qp up PUSupported = mempty up PUNotSupported = error "relation: Unit product support mode is disabled!" -- | Compose SQL String from 'QueryRestriction'. composeRestrict :: Keyword -> QueryRestriction c -> StringSQL composeRestrict k = d where d [] = mempty d ps@(_:_) = k <> foldr1 SQL.and [ unsafeProjectionStringSql p | p <- ps ] -- | Compose WHERE clause from 'QueryRestriction'. composeWhere :: QueryRestriction Context.Flat -> StringSQL composeWhere = composeRestrict WHERE -- | Compose HAVING clause from 'QueryRestriction'. composeHaving :: QueryRestriction Context.Aggregated -> StringSQL composeHaving = composeRestrict HAVING relational-query-0.8.3.2/src/Database/Relational/Query/TH.hs0000644000000000000000000006361713000574776021734 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ParallelListComp #-} -- | -- Module : Database.Relational.Query.TH -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines templates for Haskell record type and type class instances -- to define column projection on SQL query like Haskell records. -- Templates are generated by also using functions of "Database.Record.TH" module, -- so mapping between list of untyped SQL type and Haskell record type will be done too. module Database.Relational.Query.TH ( -- * All templates about table defineTable, defineTableDefault, -- * Inlining typed 'Query' unsafeInlineQuery, inlineQuery, -- * Column projections and basic 'Relation' for Haskell record defineTableTypesAndRecord, defineTableTypesAndRecordDefault, -- * Constraint key templates defineHasPrimaryKeyInstance, defineHasPrimaryKeyInstanceWithConfig, defineHasPrimaryKeyInstanceDefault, defineHasNotNullKeyInstance, defineHasNotNullKeyInstanceWithConfig, defineHasNotNullKeyInstanceDefault, defineScalarDegree, -- * Column projections defineColumns, defineColumnsDefault, -- * Table metadata type and basic 'Relation' defineTableTypes, defineTableTypesWithConfig, defineTableTypesDefault, -- * Basic SQL templates generate rules definePrimaryQuery, definePrimaryUpdate, -- * Var expression templates derivationExpDefault, tableVarExpDefault, relationVarExp, relationVarExpDefault, -- * Derived SQL templates from table definitions defineSqlsWithPrimaryKey, defineSqlsWithPrimaryKeyDefault, -- * Add type class instance against record type defineProductConstructorInstance, -- * Reify makeRelationalRecordDefault, reifyRelation, ) where import Data.Char (toUpper, toLower) import Data.List (foldl1') import Data.Array.IArray ((!)) import Language.Haskell.TH (Name, nameBase, Q, reify, TypeQ, Type (AppT, ConT), ExpQ, tupleT, appT, arrowT, Dec, stringE, listE) import Language.Haskell.TH.Compat.Reify (unVarI) import Language.Haskell.TH.Name.CamelCase (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon, toDataCon) import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE) import Database.Record.TH (columnOffsetsVarNameDefault, recordTypeName, recordType, defineRecordTypeWithConfig, defineHasColumnConstraintInstance) import qualified Database.Record.TH as Record import Database.Relational.Query (Table, Pi, id', Relation, ProductConstructor (..), NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..), Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation), defaultConfig, relationalQuerySQL, Query, relationalQuery, KeyUpdate, Insert, derivedInsert, InsertQuery, derivedInsertQuery, HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate) import Database.Relational.Query.Scalar (defineScalarDegree) import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey) import Database.Relational.Query.Table (TableDerivable (..)) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Relation (derivedRelation) import Database.Relational.Query.SQL (QuerySuffix) import Database.Relational.Query.Type (unsafeTypedQuery) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi -- | Rule template to infer constraint key. defineHasConstraintKeyInstance :: TypeQ -- ^ Constraint type -> TypeQ -- ^ Record type -> TypeQ -- ^ Key type -> [Int] -- ^ Indexes specifies key -> Q [Dec] -- ^ Result 'HasConstraintKey' declaration defineHasConstraintKeyInstance constraint recType colType indexes = do -- kc <- defineHasColumnConstraintInstance constraint recType index ck <- [d| instance HasConstraintKey $constraint $recType $colType where constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes]) |] return ck -- | Rule template to infer primary key. defineHasPrimaryKeyInstance :: TypeQ -- ^ Record type -> TypeQ -- ^ Key type -> [Int] -- ^ Indexes specifies key -> Q [Dec] -- ^ Result constraint key declarations defineHasPrimaryKeyInstance recType colType indexes = do kc <- Record.defineHasPrimaryKeyInstance recType indexes ck <- defineHasConstraintKeyInstance [t| Primary |] recType colType indexes return $ kc ++ ck -- | Rule template to infer primary key. defineHasPrimaryKeyInstanceWithConfig :: Config -- ^ configuration parameters -> String -- ^ Schema name -> String -- ^ Table name -> TypeQ -- ^ Column type -> [Int] -- ^ Primary key index -> Q [Dec] -- ^ Declarations of primary constraint key defineHasPrimaryKeyInstanceWithConfig config scm = defineHasPrimaryKeyInstance . recordType (recordConfig $ nameConfig config) scm {-# DEPRECATED defineHasPrimaryKeyInstanceDefault "Use ' defineHasPrimaryKeyInstanceWithConfig defaultConfig ' instead of this." #-} -- | Rule template to infer primary key. defineHasPrimaryKeyInstanceDefault :: String -- ^ Schema name -> String -- ^ Table name -> TypeQ -- ^ Column type -> [Int] -- ^ Primary key index -> Q [Dec] -- ^ Declarations of primary constraint key defineHasPrimaryKeyInstanceDefault = defineHasPrimaryKeyInstanceWithConfig defaultConfig -- | Rule template to infer not-null key. defineHasNotNullKeyInstance :: TypeQ -- ^ Record type -> Int -- ^ Column index -> Q [Dec] -- ^ Result 'ColumnConstraint' declaration defineHasNotNullKeyInstance = defineHasColumnConstraintInstance [t| NotNull |] -- | Rule template to infer not-null key. defineHasNotNullKeyInstanceWithConfig :: Config -- ^ configuration parameters -> String -- ^ Schema name -> String -- ^ Table name -> Int -- ^ NotNull key index -> Q [Dec] -- ^ Declaration of not-null constraint key defineHasNotNullKeyInstanceWithConfig config scm = defineHasNotNullKeyInstance . recordType (recordConfig $ nameConfig config) scm {-# DEPRECATED defineHasNotNullKeyInstanceDefault "Use ' defineHasNotNullKeyInstanceWithConfig defaultConfig ' instead of this." #-} -- | Rule template to infer not-null key. defineHasNotNullKeyInstanceDefault :: String -- ^ Schema name -> String -- ^ Table name -> Int -- ^ NotNull key index -> Q [Dec] -- ^ Declaration of not-null constraint key defineHasNotNullKeyInstanceDefault = defineHasNotNullKeyInstanceWithConfig defaultConfig -- | Column projection path 'Pi' template. columnTemplate' :: TypeQ -- ^ Record type -> VarName -- ^ Column declaration variable name -> ExpQ -- ^ Column index expression in record (begin with 0) -> TypeQ -- ^ Column type -> Q [Dec] -- ^ Column projection path declaration columnTemplate' recType var' iExp colType = do let var = varName var' simpleValD var [t| Pi $recType $colType |] [| UnsafePi.definePi $(iExp) |] -- | Column projection path 'Pi' and constraint key template. columnTemplate :: Maybe (TypeQ, VarName) -- ^ May Constraint type and constraint object name -> TypeQ -- ^ Record type -> VarName -- ^ Column declaration variable name -> ExpQ -- ^ Column index expression in record (begin with 0) -> TypeQ -- ^ Column type -> Q [Dec] -- ^ Column projection path declaration columnTemplate mayConstraint recType var' iExp colType = do col <- columnTemplate' recType var' iExp colType cr <- maybe (return []) ( \(constraint, cname') -> do simpleValD (varName cname') [t| Key $constraint $recType $colType |] [| unsafeDefineConstraintKey $(iExp) |] ) mayConstraint return $ col ++ cr -- | Column projection path 'Pi' templates. defineColumns :: ConName -- ^ Record type name -> [((VarName, TypeQ), Maybe (TypeQ, VarName))] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineColumns recTypeName cols = do let defC ((cn, ct), mayCon) ix = columnTemplate mayCon (toTypeCon recTypeName) cn [| $(toVarExp . columnOffsetsVarNameDefault $ conName recTypeName) ! $(integralE ix) |] ct fmap concat . sequence $ zipWith defC cols [0 :: Int ..] -- | Make column projection path and constraint key templates using default naming rule. defineColumnsDefault :: ConName -- ^ Record type name -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineColumnsDefault recTypeName cols = defineColumns recTypeName [((varN n, ct), fmap (withCName n) mayC) | ((n, ct), mayC) <- cols] where varN name = varCamelcaseName (name ++ "'") withCName name t = (t, varCamelcaseName ("constraint_key_" ++ name)) -- | Rule template to infer table derivations. defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec] defineTableDerivableInstance recordType' table columns = [d| instance TableDerivable $recordType' where derivedTable = Table.table $(stringE table) $(listE $ map stringE columns) |] -- | Template to define inferred entries from table type. defineTableDerivations :: VarName -- ^ Table declaration variable name -> VarName -- ^ Relation declaration variable name -> VarName -- ^ Insert statement declaration variable name -> VarName -- ^ InsertQuery statement declaration variable name -> TypeQ -- ^ Record type -> Q [Dec] -- ^ Table and Relation declaration defineTableDerivations tableVar' relVar' insVar' insQVar' recordType' = do let tableVar = varName tableVar' tableDs <- simpleValD tableVar [t| Table $recordType' |] [| derivedTable |] let relVar = varName relVar' relDs <- simpleValD relVar [t| Relation () $recordType' |] [| derivedRelation |] let insVar = varName insVar' insDs <- simpleValD insVar [t| Insert $recordType' |] [| derivedInsert id' |] let insQVar = varName insQVar' insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType' -> InsertQuery p |] [| derivedInsertQuery id' |] return $ concat [tableDs, relDs, insDs, insQDs] -- | 'Table' and 'Relation' templates. defineTableTypes :: VarName -- ^ Table declaration variable name -> VarName -- ^ Relation declaration variable name -> VarName -- ^ Insert statement declaration variable name -> VarName -- ^ InsertQuery statement declaration variable name -> TypeQ -- ^ Record type -> String -- ^ Table name in SQL ex. FOO_SCHEMA.table0 -> [String] -- ^ Column names -> Q [Dec] -- ^ Table and Relation declaration defineTableTypes tableVar' relVar' insVar' insQVar' recordType' table columns = do iDs <- defineTableDerivableInstance recordType' table columns dDs <- defineTableDerivations tableVar' relVar' insVar' insQVar' recordType' return $ iDs ++ dDs tableSQL :: Bool -> SchemaNameMode -> IdentifierQuotation -> String -> String -> String tableSQL normalize snm iq schema table = case snm of SchemaQualified -> (qt normalizeS) ++ '.' : (qt normalizeT) SchemaNotQualified -> (qt normalizeT) where normalizeS | normalize = map toUpper schema | otherwise = schema normalizeT | normalize = map toLower table | otherwise = table qt = quote iq quote :: IdentifierQuotation -> String -> String quote NoQuotation s = s quote (Quotation q) s = q : (escape s) ++ q : [] where escape = (>>= (\c -> if c == q then [q, q] else [c])) derivationVarNameDefault :: String -> VarName derivationVarNameDefault = (`varNameWithPrefix` "derivationFrom") -- | Make 'TableDerivation' variable expression template from table name using default naming rule. derivationExpDefault :: String -- ^ Table name string -> ExpQ -- ^ Result var Exp derivationExpDefault = toVarExp . derivationVarNameDefault tableVarNameDefault :: String -> VarName tableVarNameDefault = (`varNameWithPrefix` "tableOf") -- | Make 'Table' variable expression template from table name using default naming rule. tableVarExpDefault :: String -- ^ Table name string -> ExpQ -- ^ Result var Exp tableVarExpDefault = toVarExp . tableVarNameDefault -- | Make 'Relation' variable expression template from table name using specified naming rule. relationVarExp :: Config -- ^ Configuration which has naming rules of templates -> String -- ^ Schema name string -> String -- ^ Table name string -> ExpQ -- ^ Result var Exp relationVarExp config scm = toVarExp . relationVarName (nameConfig config) scm {-# DEPRECATED relationVarExpDefault "Use ' relationVarExp defaultConfig ' instead of this." #-} -- | Make 'Relation' variable expression template from table name using default naming rule. relationVarExpDefault :: String -- ^ Schema name string -> String -- ^ Table name string -> ExpQ -- ^ Result var Exp relationVarExpDefault = relationVarExp defaultConfig -- | Make template for 'ProductConstructor' instance. defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec] defineProductConstructorInstance recTypeQ recData colTypes = [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where productConstructor = $(recData) |] -- | Make template for record 'ProductConstructor' instance using specified naming rule. defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec] defineProductConstructorInstanceWithConfig config schema table colTypes = do let typeName = recordTypeName (recordConfig $ nameConfig config) schema table defineProductConstructorInstance (toTypeCon typeName) (toDataCon typeName) colTypes -- | Make templates about table and column metadatas using specified naming rule. defineTableTypesWithConfig :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type -> Q [Dec] -- ^ Result declarations defineTableTypesWithConfig config schema table columns = do let nmconfig = nameConfig config recConfig = recordConfig nmconfig tableDs <- defineTableTypes (tableVarNameDefault table) (relationVarName nmconfig schema table) (table `varNameWithPrefix` "insert") (table `varNameWithPrefix` "insertQuery") (recordType recConfig schema table) (tableSQL (normalizedTableName config) (schemaNameMode config) (identifierQuotation config) schema table) (map ((quote (identifierQuotation config)) . fst . fst) columns) colsDs <- defineColumnsDefault (recordTypeName recConfig schema table) columns return $ tableDs ++ colsDs {-# DEPRECATED defineTableTypesDefault "Use defineTableTypesWithConfig instead of this." #-} -- | Make templates about table and column metadatas using default naming rule. defineTableTypesDefault :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type -> Q [Dec] -- ^ Result declarations defineTableTypesDefault = defineTableTypesWithConfig -- | Make templates about table, column and haskell record using specified naming rule. defineTableTypesAndRecord :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ Column names and types -> [Name] -- ^ Record derivings -> Q [Dec] -- ^ Result declarations defineTableTypesAndRecord config schema table columns derives = do recD <- defineRecordTypeWithConfig (recordConfig $ nameConfig config) schema table columns derives rconD <- defineProductConstructorInstanceWithConfig config schema table [t | (_, t) <- columns] tableDs <- defineTableTypesWithConfig config schema table [(c, Nothing) | c <- columns ] return $ recD ++ rconD ++ tableDs {-# DEPRECATED defineTableTypesAndRecordDefault "Use defineTableTypesAndRecord instead of this." #-} -- | Make templates about table, column and haskell record using default naming rule. defineTableTypesAndRecordDefault :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ Column names and types -> [Name] -- ^ Record derivings -> Q [Dec] -- ^ Result declarations defineTableTypesAndRecordDefault = defineTableTypesAndRecord -- | Template of derived primary 'Query'. definePrimaryQuery :: VarName -- ^ Variable name of result declaration -> TypeQ -- ^ Parameter type of 'Query' -> TypeQ -- ^ Record type of 'Query' -> ExpQ -- ^ 'Relation' expression -> Q [Dec] -- ^ Result 'Query' declaration definePrimaryQuery toDef' paramType recType relE = do let toDef = varName toDef' simpleValD toDef [t| Query $paramType $recType |] [| relationalQuery (primary $relE) |] -- | Template of derived primary 'Update'. definePrimaryUpdate :: VarName -- ^ Variable name of result declaration -> TypeQ -- ^ Parameter type of 'Update' -> TypeQ -- ^ Record type of 'Update' -> ExpQ -- ^ 'Table' expression -> Q [Dec] -- ^ Result 'Update' declaration definePrimaryUpdate toDef' paramType recType tableE = do let toDef = varName toDef' simpleValD toDef [t| KeyUpdate $paramType $recType |] [| primaryUpdate $tableE |] -- | SQL templates derived from primary key. defineSqlsWithPrimaryKey :: VarName -- ^ Variable name of select query definition from primary key -> VarName -- ^ Variable name of update statement definition from primary key -> TypeQ -- ^ Primary key type -> TypeQ -- ^ Record type -> ExpQ -- ^ Relation expression -> ExpQ -- ^ Table expression -> Q [Dec] -- ^ Result declarations defineSqlsWithPrimaryKey sel upd paramType recType relE tableE = do selD <- definePrimaryQuery sel paramType recType relE updD <- definePrimaryUpdate upd paramType recType tableE return $ selD ++ updD -- | SQL templates derived from primary key using default naming rule. defineSqlsWithPrimaryKeyDefault :: String -- ^ Table name of Database -> TypeQ -- ^ Primary key type -> TypeQ -- ^ Record type -> ExpQ -- ^ Relation expression -> ExpQ -- ^ Table expression -> Q [Dec] -- ^ Result declarations defineSqlsWithPrimaryKeyDefault table = defineSqlsWithPrimaryKey sel upd where sel = table `varNameWithPrefix` "select" upd = table `varNameWithPrefix` "update" -- | All templates about primary key. defineWithPrimaryKey :: Config -> String -- ^ Schema name -> String -- ^ Table name string -> TypeQ -- ^ Type of primary key -> [Int] -- ^ Indexes specifies primary key -> Q [Dec] -- ^ Result declarations defineWithPrimaryKey config schema table keyType ixs = do instD <- defineHasPrimaryKeyInstanceWithConfig config schema table keyType ixs let recType = recordType (recordConfig $ nameConfig config) schema table tableE = tableVarExpDefault table relE = relationVarExp config schema table sqlsD <- defineSqlsWithPrimaryKeyDefault table keyType recType relE tableE return $ instD ++ sqlsD -- | All templates about not-null key. defineWithNotNullKeyWithConfig :: Config -> String -> String -> Int -> Q [Dec] defineWithNotNullKeyWithConfig = defineHasNotNullKeyInstanceWithConfig -- | Generate all templtes about table using specified naming rule. defineTable :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name string of Database -> String -- ^ Table name string of Database -> [(String, TypeQ)] -- ^ Column names and types -> [Name] -- ^ derivings for Record type -> [Int] -- ^ Primary key index -> Maybe Int -- ^ Not null key index -> Q [Dec] -- ^ Result declarations defineTable config schema table columns derives primaryIxs mayNotNullIdx = do tblD <- defineTableTypesAndRecord config schema table columns derives let pairT x y = appT (appT (tupleT 2) x) y keyType = foldl1' pairT . map (snd . (columns !!)) $ primaryIxs primD <- case primaryIxs of [] -> return [] ixs -> defineWithPrimaryKey config schema table keyType ixs nnD <- maybeD (\i -> defineWithNotNullKeyWithConfig config schema table i) mayNotNullIdx return $ tblD ++ primD ++ nnD {-# DEPRECATED defineTableDefault "Use defineTable instead of this." #-} -- | Generate all templtes about table using default naming rule. defineTableDefault :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name string of Database -> String -- ^ Table name string of Database -> [(String, TypeQ)] -- ^ Column names and types -> [Name] -- ^ derivings for Record type -> [Int] -- ^ Primary key index -> Maybe Int -- ^ Not null key index -> Q [Dec] -- ^ Result declarations defineTableDefault = defineTable -- | Unsafely inlining SQL string 'Query' in compile type. unsafeInlineQuery :: TypeQ -- ^ Query parameter type -> TypeQ -- ^ Query result type -> String -- ^ SQL string query to inline -> VarName -- ^ Variable name for inlined query -> Q [Dec] -- ^ Result declarations unsafeInlineQuery p r sql qVar' = simpleValD (varName qVar') [t| Query $p $r |] [| unsafeTypedQuery $(stringE sql) |] -- | Extract param type and result type from defined Relation reifyRelation :: Name -- ^ Variable name which has Relation type -> Q (Type, Type) -- ^ Extracted param type and result type from Relation type reifyRelation relVar = do relInfo <- reify relVar case unVarI relInfo of Just (_, (AppT (AppT (ConT prn) p) r), _) | prn == ''Relation -> return (p, r) _ -> fail $ "expandRelation: Variable must have Relation type: " ++ show relVar -- | Inlining composed 'Query' in compile type. inlineQuery :: Name -- ^ Top-level variable name which has 'Relation' type -> Relation p r -- ^ Object which has 'Relation' type -> Config -- ^ Configuration to generate SQL -> QuerySuffix -- ^ suffix SQL words -> String -- ^ Variable name to define as inlined query -> Q [Dec] -- ^ Result declarations inlineQuery relVar rel config sufs qns = do (p, r) <- reifyRelation relVar unsafeInlineQuery (return p) (return r) (relationalQuerySQL config rel sufs) (varCamelcaseName qns) -- | Generate all templates against defined record like type constructor -- other than depending on sql-value type. makeRelationalRecordDefault :: Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration makeRelationalRecordDefault recTypeName = do let recTypeConName = ConName recTypeName ((tyCon, dataCon), (mayNs, cts)) <- Record.reifyRecordType recTypeName pw <- Record.defineColumnOffsets recTypeConName cts cs <- maybe (return []) (\ns -> defineColumnsDefault recTypeConName [ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ]) mayNs pc <- defineProductConstructorInstance tyCon dataCon cts return $ concat [pw, cs, pc] relational-query-0.8.3.2/src/Database/Relational/Query/ProjectableExtended.hs0000644000000000000000000001617713000574776025333 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.ProjectableExtended -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines operators on various polymorphic projections -- which needs extended GHC features. module Database.Relational.Query.ProjectableExtended ( -- * Projection for nested 'Maybe's ProjectableFlattenMaybe (flatten), flattenPiMaybe, -- * Get narrower projections (!), (?!), (?!?), (!??), -- * Aggregate functions unsafeAggregateOp, count, sum', sumMaybe, avg, avgMaybe, max', maxMaybe, min', minMaybe, every, any', some', -- * Zipping projection type trick ProjectableIdZip (leftId, rightId), ProjectableRunIdsZip (runIds), flattenPh -- generalizedZip', (>?<) ) where import Prelude hiding (pi) import qualified Language.SQL.Keyword as SQL 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.Projectable (PlaceHolders, unsafeUniOp, ProjectableMaybe (flattenMaybe), ProjectableIdZip (leftId, rightId), SqlProjectable) import Database.Relational.Query.Pi (Pi) class AggregatedContext ac instance AggregatedContext Aggregated instance AggregatedContext OverWindow -- | Unsafely make aggregation uni-operator from SQL keyword. unsafeAggregateOp :: (AggregatedContext ac, SqlProjectable (p ac)) => SQL.Keyword -> Projection Flat a -> p ac b unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren) -- | Aggregation function COUNT. count :: (Integral b, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac b count = unsafeAggregateOp SQL.COUNT -- | Aggregation function SUM. sumMaybe :: (Num a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe a) sumMaybe = unsafeAggregateOp SQL.SUM -- | Aggregation function SUM. sum' :: (Num a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe a) sum' = sumMaybe . Projection.just -- | Aggregation function AVG. avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe b) avgMaybe = unsafeAggregateOp SQL.AVG -- | Aggregation function AVG. avg :: (Num a, Fractional b, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe b) avg = avgMaybe . Projection.just -- | Aggregation function MAX. maxMaybe :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe a) maxMaybe = unsafeAggregateOp SQL.MAX -- | Aggregation function MAX. max' :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe a) max' = maxMaybe . Projection.just -- | Aggregation function MIN. minMaybe :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe a) minMaybe = unsafeAggregateOp SQL.MIN -- | Aggregation function MIN. min' :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe a) min' = minMaybe . Projection.just -- | Aggregation function EVERY. every :: (AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) every = unsafeAggregateOp SQL.EVERY -- | Aggregation function ANY. any' :: (AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) any' = unsafeAggregateOp SQL.ANY -- | Aggregation function SOME. some' :: (AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) some' = unsafeAggregateOp SQL.SOME -- | Get narrower projection along with projection path. (!) :: Projection c a -- ^ Source projection -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower projected object (!) = Projection.pi -- | Get narrower projection along with projection path -- 'Maybe' phantom functor is 'map'-ed. (?!) :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a b -- ^ Projection path -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result (?!) = Projection.piMaybe -- | Get narrower projection along with projection path -- and project into result projection type. -- Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed. (?!?) :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result (?!?) = Projection.piMaybe' -- | Interface to compose phantom 'Maybe' nested type. class ProjectableFlattenMaybe a b where flatten :: ProjectableMaybe p => p a -> p b -- | Compose 'Maybe' type in projection phantom type. instance ProjectableFlattenMaybe (Maybe a) b => ProjectableFlattenMaybe (Maybe (Maybe a)) b where flatten = flatten . flattenMaybe -- | Not 'Maybe' type is not processed. instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where flatten = id -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path. flattenPiMaybe :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Projection cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type flattenPiMaybe p = flatten . Projection.piMaybe p -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path. (!??) :: (ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Projection cont c -- ^ Narrower flatten and projected object. (!??) = flattenPiMaybe -- | Interface to run recursively identity element laws. class ProjectableRunIdsZip a b where runIds :: ProjectableIdZip p => p a -> p b -- | Run left identity element law. instance ProjectableRunIdsZip a b => ProjectableRunIdsZip ((), a) b where runIds = runIds . leftId -- | Run right identity element law. instance ProjectableRunIdsZip a b => ProjectableRunIdsZip (a, ()) b where runIds = runIds . rightId -- | Base case definition to run recursively identity element laws. instance ProjectableRunIdsZip a a where runIds = id -- | Specialize 'runIds' for 'PlaceHolders' type. flattenPh :: ProjectableRunIdsZip a b => PlaceHolders a -> PlaceHolders b flattenPh = runIds -- -- | Binary operator the same as 'generalizedZip'. -- (>?<) :: (ProjectableIdZip p, ProjectableRunIdsZip (a, b) c) -- => p a -> p b -> p c -- (>?<) = generalizedZip' infixl 8 !, ?!, ?!?, !?? -- infixl 1 >?< relational-query-0.8.3.2/src/Database/Relational/Query/Context.hs0000644000000000000000000000142713000574776023034 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Database.Relational.Query.Context -- Copyright : 2013 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 -- | Type tag for aggregatings power set data Power relational-query-0.8.3.2/src/Database/Relational/Query/Projection.hs0000644000000000000000000001505113000574776023522 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Projection -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines query projection type structure and interfaces. module Database.Relational.Query.Projection ( -- * Projection data structure and interface Projection, width, columns, untype, unsafeFromSqlTerms, unsafeFromQualifiedSubQuery, unsafeFromScalarSubQuery, unsafeFromTable, unsafeStringSql, -- * Projections pi, piMaybe, piMaybe', flattenMaybe, just, unsafeToAggregated, unsafeToFlat, unsafeChangeContext, unsafeStringSqlNotNullMaybe, pfmap, pap, -- * List Projection ListProjection, list, unsafeListFromSubQuery, unsafeStringSqlList ) where import Prelude hiding (pi) import qualified Language.SQL.Keyword as SQL 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.Sub (SubQuery, UntypedProjection, Projection, untypeProjection, typedProjection, Qualified) 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) import qualified Database.Relational.Query.Sub as SubQuery -- | Unsafely get SQL term from 'Proejction'. unsafeStringSql :: Projection c r -> StringSQL unsafeStringSql = unsafeProjectionStringSql -- | Get column SQL string list of projection. columns :: Projection c r -- ^ Source 'Projection' -> [ColumnSQL] -- ^ Result SQL string list columns = projectionColumns -- | Width of 'Projection'. width :: Projection c r -> Int width = widthOfUntypedProjection . untypeProjection -- | Unsafely get untyped projection. untype :: Projection c r -> UntypedProjection untype = untypeProjection -- | Unsafely generate 'Projection' from qualified (joined) sub-query. unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection c t unsafeFromQualifiedSubQuery = typedProjection . untypedProjectionFromJoinedSubQuery -- | Unsafely generate 'Projection' from scalar sub-query. unsafeFromScalarSubQuery :: SubQuery -> Projection c t unsafeFromScalarSubQuery = typedProjection . untypedProjectionFromScalarSubQuery -- | Unsafely generate unqualified 'Projection' from 'Table'. unsafeFromTable :: Table r -> Projection c r unsafeFromTable = unsafeProjectFromColumns . Table.columns -- | Unsafely generate 'Projection' from SQL expression strings. unsafeFromSqlTerms :: [StringSQL] -> Projection c t unsafeFromSqlTerms = unsafeProjectFromColumns . map columnSQL' -- | Unsafely trace projection path. unsafeProject :: Projection c a' -> Pi a b -> Projection c b' unsafeProject p pi' = unsafeProjectFromColumns . (`UnsafePi.pi` pi') . columns $ p -- | Trace projection path to get narrower 'Projection'. pi :: Projection c a -- ^ Source 'Projection' -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower 'Projection' pi = unsafeProject -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. piMaybe :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a b -- ^ Projection path -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result piMaybe = unsafeProject -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. -- Leaf type of projection path is 'Maybe'. piMaybe' :: Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result piMaybe' = unsafeProject unsafeCast :: Projection c r -> Projection c r' unsafeCast = typedProjection . untypeProjection -- | Composite nested 'Maybe' on projection phantom type. flattenMaybe :: Projection c (Maybe (Maybe a)) -> Projection c (Maybe a) flattenMaybe = unsafeCast -- | Cast into 'Maybe' on projection phantom type. just :: Projection c r -> Projection c (Maybe r) just = unsafeCast -- | Unsafely cast context type tag. unsafeChangeContext :: Projection c r -> Projection c' r unsafeChangeContext = typedProjection . untypeProjection -- | Unsafely lift to aggregated context. unsafeToAggregated :: Projection Flat r -> Projection Aggregated r unsafeToAggregated = unsafeChangeContext -- | Unsafely down to flat context. unsafeToFlat :: Projection Aggregated r -> Projection Flat r unsafeToFlat = unsafeChangeContext notNullMaybeConstraint :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> NotNullColumnConstraint r notNullMaybeConstraint = const KeyConstraint.columnConstraint -- | Unsafely get SQL string expression of not null key projection. unsafeStringSqlNotNullMaybe :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> StringSQL unsafeStringSqlNotNullMaybe p = showsColumnSQL . (!! KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p -- | Projectable fmap of 'Projection' type. pfmap :: ProductConstructor (a -> b) => (a -> b) -> Projection c a -> Projection c b _ `pfmap` p = unsafeCast p -- | Projectable ap of 'Projection' type. pap :: Projection c (a -> b) -> Projection c a -> Projection c b pf `pap` pa = typedProjection $ untypeProjection pf ++ untypeProjection pa -- | Projection type for row list. data ListProjection p t = List [p t] | Sub SubQuery -- | Make row list projection from 'Projection' list. list :: [p t] -> ListProjection p t list = List -- | Make row list projection from 'SubQuery'. unsafeListFromSubQuery :: SubQuery -> ListProjection p t unsafeListFromSubQuery = Sub -- | Map projection show operatoions and concatinate to single SQL expression. unsafeStringSqlList :: (p t -> StringSQL) -> ListProjection p t -> StringSQL unsafeStringSqlList sf = d where d (List ps) = listStringSQL $ map sf ps d (Sub sub) = SQL.paren $ SubQuery.showSQL sub relational-query-0.8.3.2/src/Database/Relational/Query/Derives.hs0000644000000000000000000001077313000574776023015 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Derives -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed SQLs derived from type informations. module Database.Relational.Query.Derives ( -- * Query derivation specifiedKey, unique, primary', primary, -- * Update derivation updateByConstraintKey, primaryUpdate, updateValuesWithKey, -- * Derived objects from table derivedUniqueRelation ) where 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) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (placeholder, (.=.)) import Database.Relational.Query.ProjectableExtended ((!)) import Database.Relational.Query.Monad.Class (wheres) import Database.Relational.Query.Monad.BaseType (Relation) import Database.Relational.Query.Relation (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) import Database.Relational.Query.Constraint (Key, Primary, Unique, projectionKey, uniqueKey, HasConstraintKey(constraintKey)) import qualified Database.Relational.Query.Constraint as Constraint import Database.Relational.Query.Type (KeyUpdate, typedKeyUpdate) -- | Query restricted with specified key. specifiedKey :: PersistableWidth p => Pi a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'. -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' specifiedKey key rel = relation' $ do q <- query rel (param, ()) <- placeholder (\ph -> wheres $ q ! key .=. ph) return (param, q) -- | Query restricted with specified unique key. unique :: PersistableWidth p => Key Unique a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'. -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' unique = specifiedKey . projectionKey -- | Query restricted with specified primary key. primary' :: PersistableWidth p => Key Primary a p -- ^ Primary key proof object which record type is 'a' and key type is 'p'. -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' primary' = specifiedKey . projectionKey -- | Query restricted with inferred primary key. primary :: HasConstraintKey Primary a p => Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' primary = primary' constraintKey -- | Convert from Haskell type `r` into SQL value `q` list expected by update form like -- -- /UPDATE SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / -- -- using derived 'RecordToSql' proof object. updateValuesWithKey :: ToSql q r => Pi r p -> r -> [q] updateValuesWithKey = unsafeUpdateValuesWithIndexes recordToSql . unsafeExpandIndexes -- | Typed 'KeyUpdate' using specified constraint key. updateByConstraintKey :: Table r -- ^ 'Table' to update -> Key c r p -- ^ Key with constraint 'c', record type 'r' and columns type 'p' -> KeyUpdate p r -- ^ Result typed 'Update' updateByConstraintKey table' = typedKeyUpdate table' . Constraint.projectionKey -- | Typed 'KeyUpdate' using inferred primary key. primaryUpdate :: (HasConstraintKey Primary r p) => Table r -- ^ 'Table' to update -> KeyUpdate p r -- ^ Result typed 'Update' primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey) -- | 'UniqueRelation' inferred from table. derivedUniqueRelation :: TableDerivable r => Key Unique r k -- ^ Unique key proof object which record type is 'a' and key type is 'p'. -> Projection c k -- ^ Unique key value to specify. -> UniqueRelation () c r -- ^ Result restricted 'Relation' derivedUniqueRelation uk kp = unsafeUnique . relation $ do r <- query derivedRelation wheres $ r ! projectionKey uk .=. Projection.unsafeChangeContext kp return r relational-query-0.8.3.2/src/Database/Relational/Query/Pure.hs0000644000000000000000000001475013000574776022326 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Pure -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines interfaces between haskell pure values -- and query internal projection values. module Database.Relational.Query.Pure ( -- * Interface to specify record constructors. ProductConstructor (..), -- * Constant SQL Terms ShowConstantTermsSQL (..), showConstantTermsSQL ) where import Data.Monoid (mconcat) import Data.Int (Int8, Int16, Int32, Int64) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import Text.Printf (PrintfArg, printf) import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, formatTime) import Data.Time.Locale.Compat (defaultTimeLocale) import Language.SQL.Keyword (Keyword (..)) import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) -- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'. class ProductConstructor r where -- | The constructor which has type 'r'. productConstructor :: r -- | ProductConstructor instance of pair. instance ProductConstructor (a -> b -> (a, b)) where productConstructor = (,) -- | Constant integral SQL expression. intExprSQL :: (Show a, Integral a) => a -> StringSQL intExprSQL = stringSQL . show intTermsSQL :: (Show a, Integral a) => a -> [StringSQL] intTermsSQL = (:[]) . intExprSQL -- | Escape 'String' for constant SQL string expression. escapeStringToSqlExpr :: String -> String escapeStringToSqlExpr = rec where rec "" = "" rec ('\'':cs) = '\'' : '\'' : rec cs rec (c:cs) = c : rec cs -- | From 'String' into constant SQL string expression. stringExprSQL :: String -> StringSQL stringExprSQL = stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr stringTermsSQL :: String -> [StringSQL] stringTermsSQL = (:[]) . stringExprSQL -- | Interface for constant SQL term list. class ShowConstantTermsSQL a where showConstantTermsSQL' :: a -> [StringSQL] -- | String interface of 'showConstantTermsSQL''. showConstantTermsSQL :: ShowConstantTermsSQL a => a -> [String] showConstantTermsSQL = map showStringSQL . showConstantTermsSQL' -- | Constant SQL terms of 'Int8'. instance ShowConstantTermsSQL Int8 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int16'. instance ShowConstantTermsSQL Int16 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int32'. instance ShowConstantTermsSQL Int32 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int64'. instance ShowConstantTermsSQL Int64 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int'. -- Use this carefully, because this is architecture dependent size of integer type. instance ShowConstantTermsSQL Int where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'String'. instance ShowConstantTermsSQL String where showConstantTermsSQL' = stringTermsSQL -- | Constant SQL terms of 'ByteString'. instance ShowConstantTermsSQL ByteString where showConstantTermsSQL' = stringTermsSQL . T.unpack . T.decodeUtf8 -- | Constant SQL terms of 'LB.ByteString'. instance ShowConstantTermsSQL LB.ByteString where showConstantTermsSQL' = mconcat . map showConstantTermsSQL' . LB.toChunks -- | Constant SQL terms of 'Text'. instance ShowConstantTermsSQL Text where showConstantTermsSQL' = stringTermsSQL . T.unpack -- | Constant SQL terms of 'LT.Text'. instance ShowConstantTermsSQL LT.Text where showConstantTermsSQL' = mconcat . map showConstantTermsSQL' . LT.toChunks -- | Constant SQL terms of 'Char'. instance ShowConstantTermsSQL Char where showConstantTermsSQL' = stringTermsSQL . (:"") -- | Constant SQL terms of 'Bool'. instance ShowConstantTermsSQL Bool where showConstantTermsSQL' = (:[]) . stringSQL . d where d True = "(0=0)" d False = "(0=1)" floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> [StringSQL] floatTerms f = (:[]) . stringSQL $ printf fmt f where fmt | f >= 0 = "%f" | otherwise = "(%f)" -- | Constant SQL terms of 'Float'. Caution for floating-point error rate. instance ShowConstantTermsSQL Float where showConstantTermsSQL' = floatTerms -- | Constant SQL terms of 'Double'. Caution for floating-point error rate. instance ShowConstantTermsSQL Double where showConstantTermsSQL' = floatTerms constantTimeTerms :: FormatTime t => Keyword -> String -> t -> [StringSQL] constantTimeTerms kw fmt t = [mconcat [kw, stringExprSQL $ formatTime defaultTimeLocale fmt t]] -- | Constant SQL terms of 'Day'. instance ShowConstantTermsSQL Day where showConstantTermsSQL' = constantTimeTerms DATE "%Y-%m-%d" -- | Constant SQL terms of 'TimeOfDay'. instance ShowConstantTermsSQL TimeOfDay where showConstantTermsSQL' = constantTimeTerms TIME "%H:%M:%S" -- | Constant SQL terms of 'LocalTime'. instance ShowConstantTermsSQL LocalTime where showConstantTermsSQL' = constantTimeTerms TIMESTAMP "%Y-%m-%d %H:%M:%S" -- | Constant SQL terms of 'ZonedTime'. -- This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal. instance ShowConstantTermsSQL ZonedTime where showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z" -- | Constant SQL terms of 'UTCTime'. -- This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal with UTC timezone. instance ShowConstantTermsSQL UTCTime where showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z" showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> [StringSQL] showMaybeTerms wa = d where d (Just a) = showConstantTermsSQL' a d Nothing = replicate (runPersistableRecordWidth wa) $ stringSQL "NULL" -- | Constant SQL terms of 'Maybe' type. Width inference is required. instance (PersistableWidth a, ShowConstantTermsSQL a) => ShowConstantTermsSQL (Maybe a) where showConstantTermsSQL' = showMaybeTerms persistableWidth -- | Constant SQL terms of '(a, b)' type. instance (ShowConstantTermsSQL a, ShowConstantTermsSQL b) => ShowConstantTermsSQL (a, b) where showConstantTermsSQL' (a, b) = showConstantTermsSQL' a ++ showConstantTermsSQL' b relational-query-0.8.3.2/src/Database/Relational/Query/Type.hs0000644000000000000000000003073613000574776022336 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Type -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed SQL. module Database.Relational.Query.Type ( -- * Typed query statement Query (..), unsafeTypedQuery, relationalQuery', relationalQuery, relationalQuerySQL, -- * Typed update statement KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate, typedUpdateAllColumn, restrictedUpdateAllColumn, restrictedUpdateTableAllColumn, updateSQL, -- * Typed insert statement Insert (..), untypeChunkInsert, chunkSizeOfInsert, unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert, typedInsertValue', typedInsertValue, derivedInsertValue', derivedInsertValue, InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', typedInsertQuery, derivedInsertQuery, insertQuerySQL, -- * Typed delete statement Delete (..), unsafeTypedDelete, typedDelete', typedDelete, derivedDelete', derivedDelete, deleteSQL, -- * Generalized interfaces UntypeableNoFetch (..) ) where import Data.Monoid ((<>)) import Database.Record (PersistableWidth) 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) import Database.Relational.Query.Monad.Register (Register) import Database.Relational.Query.Relation (tableOf) import Database.Relational.Query.Effect (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 (QuerySuffix, showsQuerySuffix, insertPrefixSQL, insertSQL, insertSizedChunkSQL, updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL) -- | Query type with place-holder parameter 'p' and query result type 'a'. newtype Query p a = Query { untypeQuery :: String } -- | Unsafely make typed 'Query' from SQL string. unsafeTypedQuery :: String -- ^ Query SQL to type -> Query p a -- ^ Typed result unsafeTypedQuery = Query -- | Show query SQL string instance Show (Query p a) where show = untypeQuery -- | From 'Relation' into untyped SQL query string. relationalQuerySQL :: Config -> Relation p r -> QuerySuffix -> String relationalQuerySQL config rel qsuf = showStringSQL $ sqlFromRelationWith rel config <> showsQuerySuffix qsuf -- | From 'Relation' into typed 'Query' with suffix SQL words. relationalQuery' :: Relation p r -> QuerySuffix -> Query p r relationalQuery' rel qsuf = unsafeTypedQuery $ relationalQuerySQL defaultConfig rel qsuf -- | From 'Relation' into typed 'Query'. relationalQuery :: Relation p r -> Query p r relationalQuery = (`relationalQuery'` []) -- | Update type with key type 'p' and update record type 'a'. -- Columns to update are record columns other than key columns, -- So place-holder parameter type is the same as record type 'a'. data KeyUpdate p a = KeyUpdate { updateKey :: Pi a p , untypeKeyUpdate :: String } -- | Unsafely make typed 'KeyUpdate' from SQL string. unsafeTypedKeyUpdate :: Pi a p -> String -> KeyUpdate p a unsafeTypedKeyUpdate = KeyUpdate -- | Make typed 'KeyUpdate' from 'Table' and key columns selector 'Pi'. typedKeyUpdate :: Table a -> Pi a p -> KeyUpdate p a typedKeyUpdate tbl key = unsafeTypedKeyUpdate key $ updateOtherThanKeySQL tbl key -- | Make typed 'KeyUpdate' object using derived info specified by 'Relation' type. typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r typedKeyUpdateTable = typedKeyUpdate . tableOf -- | Show update SQL string instance Show (KeyUpdate p a) where show = untypeKeyUpdate -- | Update type with place-holder parameter 'p'. newtype Update p = Update { untypeUpdate :: String } -- | Unsafely make typed 'Update' from SQL string. unsafeTypedUpdate :: String -> Update p unsafeTypedUpdate = Update -- | Make untyped update SQL string from 'Table' and 'UpdateTarget'. updateSQL :: Config -> Table r -> UpdateTarget p r -> String updateSQL config tbl ut = showStringSQL $ updatePrefixSQL tbl <> sqlFromUpdateTarget config tbl ut -- | Make typed 'Update' from 'Config', 'Table' and 'UpdateTarget'. typedUpdate' :: Config -> Table r -> UpdateTarget p r -> Update p typedUpdate' config tbl ut = unsafeTypedUpdate $ updateSQL config tbl ut -- | Make typed 'Update' using 'defaultConfig', 'Table' and 'UpdateTarget'. typedUpdate :: Table r -> UpdateTarget p r -> Update p typedUpdate = typedUpdate' defaultConfig targetTable :: TableDerivable r => UpdateTarget p r -> Table r targetTable = const derivedTable -- | Make typed 'Update' from 'Config', derived table and 'AssignStatement' derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p derivedUpdate' config utc = typedUpdate' config (targetTable ut) ut where ut = updateTarget' utc -- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement' derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p derivedUpdate = derivedUpdate' defaultConfig -- | Make typed 'Update' from 'Table' and 'Restriction'. -- Update target is all column. typedUpdateAllColumn :: PersistableWidth r => Table r -> Restriction p r -> Update (r, p) typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. -- Update target is all column. restrictedUpdateAllColumn :: PersistableWidth r => Table r -> RestrictedStatement r (PlaceHolders p) -- ^ 'Restrict' monad context -> Update (r, p) restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction' -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. -- Update target is all column. restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r) => Relation () r -> RestrictedStatement r (PlaceHolders p) -> Update (r, p) restrictedUpdateTableAllColumn = restrictedUpdateAllColumn . tableOf -- | Show update SQL string instance Show (Update p) where show = untypeUpdate -- | Insert type to insert record type 'a'. data Insert a = Insert { untypeInsert :: String , chunkedInsert :: Maybe (String, Int) } -- | Statement to use chunked insert untypeChunkInsert :: Insert a -> String untypeChunkInsert ins = maybe (untypeInsert ins) fst $ chunkedInsert ins -- | Size to use chunked insert chunkSizeOfInsert :: Insert a -> Int chunkSizeOfInsert = maybe 1 snd . chunkedInsert -- | Unsafely make typed 'Insert' from single insert and chunked insert SQL. unsafeTypedInsert' :: String -> String -> Int -> Insert a unsafeTypedInsert' s = curry (Insert s . Just) -- | Unsafely make typed 'Insert' from single insert SQL. unsafeTypedInsert :: String -> Insert a unsafeTypedInsert s = Insert s Nothing -- | Make typed 'Insert' from 'Table' and columns selector 'Pi' with configuration parameter. typedInsert' :: Config -> Table r -> Pi r r' -> Insert r' typedInsert' config tbl pi' = unsafeTypedInsert' (insertSQL pi' tbl) ci n where (ci, n) = insertSizedChunkSQL pi' tbl $ chunksInsertSize config -- | Make typed 'Insert' from 'Table' and columns selector 'Pi'. typedInsert :: Table r -> Pi r r' -> Insert r' typedInsert = typedInsert' defaultConfig -- | Table type inferred 'Insert'. derivedInsert :: TableDerivable r => Pi r r' -> Insert r' derivedInsert = typedInsert derivedTable -- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p typedInsertValue' config tbl = unsafeTypedInsert . showStringSQL . sqlFromInsertTarget config tbl -- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object. typedInsertValue :: Table r -> InsertTarget p r -> Insert p typedInsertValue = typedInsertValue' defaultConfig -- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p derivedInsertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs where rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r rt = const derivedTable -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p derivedInsertValue = derivedInsertValue' defaultConfig -- | Show insert SQL string. instance Show (Insert a) where show = untypeInsert -- | InsertQuery type. newtype InsertQuery p = InsertQuery { untypeInsertQuery :: String } -- | Unsafely make typed 'InsertQuery' from SQL string. unsafeTypedInsertQuery :: String -> InsertQuery p unsafeTypedInsertQuery = InsertQuery -- | Make untyped insert select SQL string from 'Table', 'Pi' and 'Relation'. insertQuerySQL :: Config -> Table r -> Pi r r' -> Relation p r' -> String insertQuerySQL config tbl pi' rel = showStringSQL $ insertPrefixSQL pi' tbl <> sqlFromRelationWith rel config -- | Make typed 'InsertQuery' from columns selector 'Table', 'Pi' and 'Relation' with configuration parameter. typedInsertQuery' :: Config -> Table r -> Pi r r' -> Relation p r' -> InsertQuery p typedInsertQuery' config tbl pi' rel = unsafeTypedInsertQuery $ insertQuerySQL config tbl pi' rel -- | Make typed 'InsertQuery' from columns selector 'Table', 'Pi' and 'Relation'. typedInsertQuery :: Table r -> Pi r r' -> Relation p r' -> InsertQuery p typedInsertQuery = typedInsertQuery' defaultConfig -- | Table type inferred 'InsertQuery'. derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p derivedInsertQuery = typedInsertQuery derivedTable -- | Show insert SQL string. instance Show (InsertQuery p) where show = untypeInsertQuery -- | Delete type with place-holder parameter 'p'. newtype Delete p = Delete { untypeDelete :: String } -- | Unsafely make typed 'Delete' from SQL string. unsafeTypedDelete :: String -> Delete p unsafeTypedDelete = Delete -- | Make untyped delete SQL string from 'Table' and 'Restriction'. deleteSQL :: Config -> Table r -> Restriction p r -> String deleteSQL config tbl r = showStringSQL $ deletePrefixSQL tbl <> sqlWhereFromRestriction config tbl r -- | Make typed 'Delete' from 'Config', 'Table' and 'Restriction'. typedDelete' :: Config -> Table r -> Restriction p r -> Delete p typedDelete' config tbl r = unsafeTypedDelete $ deleteSQL config tbl r -- | Make typed 'Delete' from 'Table' and 'Restriction'. typedDelete :: Table r -> Restriction p r -> Delete p typedDelete = typedDelete' defaultConfig restrictedTable :: TableDerivable r => Restriction p r -> Table r restrictedTable = const derivedTable -- | Make typed 'Delete' from 'Config', derived table and 'RestrictContext' derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete' config rc = typedDelete' config (restrictedTable rs) rs where rs = restriction' rc -- | Make typed 'Delete' from 'defaultConfig', derived table and 'RestrictContext' derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete = derivedDelete' defaultConfig -- | Show delete SQL string instance Show (Delete p) where show = untypeDelete -- | Untype interface for typed no-result type statments -- with single type parameter which represents place-holder parameter 'p'. class UntypeableNoFetch s where untypeNoFetch :: s p -> String instance UntypeableNoFetch Insert where untypeNoFetch = untypeInsert instance UntypeableNoFetch InsertQuery where untypeNoFetch = untypeInsertQuery instance UntypeableNoFetch Update where untypeNoFetch = untypeUpdate instance UntypeableNoFetch Delete where untypeNoFetch = untypeDelete relational-query-0.8.3.2/src/Database/Relational/Query/Relation.hs0000644000000000000000000003443313000574776023170 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fsimpl-tick-factor=200 #-} -- | -- Module : Database.Relational.Query.Relation -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines re-usable Relation type -- to compose complex query. module Database.Relational.Query.Relation ( -- * Relation type table, derivedRelation, tableOf, relation, relation', aggregateRelation, aggregateRelation', UniqueRelation, unsafeUnique, unUnique, uniqueRelation', aggregatedUnique, -- * Query using relation query, queryMaybe, queryList, queryList', queryScalar, queryScalar', uniqueQuery', uniqueQueryMaybe', -- * Direct style join JoinRestriction, inner', left', right', full', inner, left, right, full, on', -- * Relation append union, except, intersect, unionAll, exceptAll, intersectAll, union', except', intersect', unionAll', exceptAll', intersectAll', ) where import Control.Applicative ((<$>)) import Database.Relational.Query.Context (Flat, Aggregated) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, unsafeTypeRelation, untypeRelation) import Database.Relational.Query.Monad.Class (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), on) import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) import qualified Database.Relational.Query.Monad.Simple as Simple import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery) 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 qualified Database.Relational.Query.Sub as SubQuery import Database.Relational.Query.Scalar (ScalarDegree) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Projection (Projection, ListProjection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, projectZip) import Database.Relational.Query.ProjectableExtended ((!)) -- | Simple 'Relation' from 'Table'. table :: Table r -> Relation () r table = unsafeTypeRelation . return . SubQuery.fromTable -- | Infered 'Relation'. derivedRelation :: TableDerivable r => Relation () r derivedRelation = table derivedTable -- | Interface to derive 'Table' type object. tableOf :: TableDerivable r => Relation () r -> Table r tableOf = const derivedTable placeHoldersFromRelation :: Relation p r -> PlaceHolders p placeHoldersFromRelation = const unsafePlaceHolders -- | Join sub-query. Query result is not 'Maybe'. query :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> m (Projection Flat r) query = fmap snd . query' -- | Join sub-query. Query result is 'Maybe'. -- The combinations of 'query' and 'queryMaybe' express -- inner joins, left outer joins, right outer joins, and full outer joins. -- Here is an example of a right outer join: -- -- @ -- outerJoin = relation $ do -- e <- queryMaybe employee -- d <- query department -- on $ e ?! E.deptId' .=. just (d ! D.deptId') -- return $ (,) |$| e |*| d -- @ queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> m (Projection Flat (Maybe r)) queryMaybe = fmap snd . queryMaybe' queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (ListProjection (Projection c) r) queryList0 = liftQualify . fmap Projection.unsafeListFromSubQuery . untypeRelation -- | List sub-query, for /IN/ and /EXIST/ with place-holder parameter 'p'. queryList' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, ListProjection (Projection c) r) queryList' rel = do ql <- queryList0 rel return (placeHoldersFromRelation rel, ql) -- | List sub-query, for /IN/ and /EXIST/. queryList :: MonadQualify ConfigureQuery m => Relation () r -> m (ListProjection (Projection c) r) queryList = queryList0 addUnitPH :: Functor f => f t -> f (PlaceHolders (), t) addUnitPH = ((,) unitPlaceHolder <$>) -- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'. relation' :: SimpleQuery p r -> Relation p r relation' = unsafeTypeRelation . Simple.toSubQuery -- | Finalize 'QuerySimple' monad and generate 'Relation'. relation :: QuerySimple (Projection Flat r) -> Relation () r relation = relation' . addUnitPH -- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'. aggregateRelation' :: AggregatedQuery p r -> Relation p r aggregateRelation' = unsafeTypeRelation . Aggregate.toSubQuery -- | Finalize 'QueryAggregate' monad and geneate 'Relation'. aggregateRelation :: QueryAggregate (Projection Aggregated r) -> Relation () r aggregateRelation = aggregateRelation' . addUnitPH -- | Restriction function type for direct style join operator. type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool) -- | Basic direct join operation with place-holder parameters. join' :: (qa -> QuerySimple (PlaceHolders pa, Projection Flat a)) -> (qb -> QuerySimple (PlaceHolders pb, Projection Flat b)) -> qa -> qb -> [JoinRestriction a b] -> Relation (pa, pb) (a, b) join' qL qR r0 r1 rs = relation' $ do (ph0, pj0) <- qL r0 (ph1, pj1) <- qR r1 sequence_ [ on $ f pj0 pj1 | f <- rs ] return (ph0 `projectZip` ph1, pj0 `projectZip` pj1) -- | Direct inner join with place-holder parameters. inner' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction a b] -- ^ Join restrictions -> Relation (pa, pb) (a, b) -- ^ Result joined relation inner' = join' query' query' -- | Direct left outer join with place-holder parameters. left' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions -> Relation (pa, pb) (a, Maybe b) -- ^ Result joined relation left' = join' query' queryMaybe' -- | Direct right outer join with place-holder parameters. right' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions -> Relation (pa, pb)(Maybe a, b) -- ^ Result joined relation right' = join' queryMaybe' query' -- | Direct full outer join with place-holder parameters. full' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions -> Relation (pa, pb) (Maybe a, Maybe b) -- ^ Result joined relation full' = join' queryMaybe' queryMaybe' -- | Basic direct join operation. join_ :: (qa -> QuerySimple (Projection Flat a)) -> (qb -> QuerySimple (Projection Flat b)) -> qa -> qb -> [JoinRestriction a b] -> Relation () (a, b) join_ qL qR r0 r1 rs = relation $ do pj0 <- qL r0 pj1 <- qR r1 sequence_ [ on $ f pj0 pj1 | f <- rs ] return $ pj0 `projectZip` pj1 -- | Direct inner join. inner :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction a b] -- ^ Join restrictions -> Relation () (a, b) -- ^ Result joined relation inner = join_ query query -- | Direct left outer join. left :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions -> Relation () (a, Maybe b) -- ^ Result joined relation left = join_ query queryMaybe -- | Direct right outer join. right :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions -> Relation () (Maybe a, b) -- ^ Result joined relation right = join_ queryMaybe query -- | Direct full outer join. full :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions -> Relation () (Maybe a, Maybe b) -- ^ Result joined relation full = join_ queryMaybe queryMaybe -- | Apply restriction for direct join style. on' :: ([JoinRestriction a b] -> Relation pc (a, b)) -> [JoinRestriction a b] -> Relation pc (a, b) on' = ($) infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'` unsafeLiftAppend :: (SubQuery -> SubQuery -> SubQuery) -> Relation p a -> Relation q a -> Relation r a unsafeLiftAppend op a0 a1 = unsafeTypeRelation $ do s0 <- untypeRelation a0 s1 <- untypeRelation a1 return $ s0 `op` s1 liftAppend :: (SubQuery -> SubQuery -> SubQuery) -> Relation () a -> Relation () a -> Relation () a liftAppend = unsafeLiftAppend -- | Union of two relations. union :: Relation () a -> Relation () a -> Relation () a union = liftAppend $ SubQuery.union Distinct -- | Union of two relations. Not distinct. unionAll :: Relation () a -> Relation () a -> Relation () a unionAll = liftAppend $ SubQuery.union All -- | Subtraction of two relations. except :: Relation () a -> Relation () a -> Relation () a except = liftAppend $ SubQuery.except Distinct -- | Subtraction of two relations. Not distinct. exceptAll :: Relation () a -> Relation () a -> Relation () a exceptAll = liftAppend $ SubQuery.except All -- | Intersection of two relations. intersect :: Relation () a -> Relation () a -> Relation () a intersect = liftAppend $ SubQuery.intersect Distinct -- | Intersection of two relations. Not distinct. intersectAll :: Relation () a -> Relation () a -> Relation () a intersectAll = liftAppend $ SubQuery.intersect All liftAppend' :: (SubQuery -> SubQuery -> SubQuery) -> Relation p a -> Relation q a -> Relation (p, q) a liftAppend' = unsafeLiftAppend -- | Union of two relations with place-holder parameters. union' :: Relation p a -> Relation q a -> Relation (p, q) a union' = liftAppend' $ SubQuery.union Distinct -- | Union of two relations with place-holder parameters. Not distinct. unionAll' :: Relation p a -> Relation q a -> Relation (p, q) a unionAll' = liftAppend' $ SubQuery.union All -- | Subtraction of two relations with place-holder parameters. except' :: Relation p a -> Relation q a -> Relation (p, q) a except' = liftAppend' $ SubQuery.except Distinct -- | Subtraction of two relations with place-holder parameters. Not distinct. exceptAll' :: Relation p a -> Relation q a -> Relation (p, q) a exceptAll' = liftAppend' $ SubQuery.except All -- | Intersection of two relations with place-holder parameters. intersect' :: Relation p a -> Relation q a -> Relation (p, q) a intersect' = liftAppend' $ SubQuery.intersect Distinct -- | Intersection of two relations with place-holder parameters. Not distinct. intersectAll' :: Relation p a -> Relation q a -> Relation (p, q) a intersectAll' = liftAppend' $ SubQuery.intersect All infixl 7 `union`, `except`, `unionAll`, `exceptAll` infixl 8 `intersect`, `intersectAll` infixl 7 `union'`, `except'`, `unionAll'`, `exceptAll'` infixl 8 `intersect'`, `intersectAll'` {- -- | Get projection width from 'Relation'. width :: Relation p r -> Int width = SubQuery.width . subQueryFromRelation -} -- | Unique relation type to compose scalar queries. newtype UniqueRelation p c r = Unique (Relation p r) -- | Unsafely specify unique relation. unsafeUnique :: Relation p r -> UniqueRelation p c r unsafeUnique = Unique -- | Discard unique attribute. unUnique :: UniqueRelation p c r -> Relation p r unUnique (Unique r) = r -- | Basic monadic join operation using 'MonadQuery'. uniqueQueryWithAttr :: NodeAttr -> UniqueRelation p c r -> QueryUnique (PlaceHolders p, Projection c r) uniqueQueryWithAttr attr = unsafeAddPlaceHolders . run where run rel = do q <- liftQualify $ do sq <- untypeRelation (unUnique rel) qualifyQuery sq Projection.unsafeChangeContext <$> unsafeUniqueSubQuery attr q -- | Join unique sub-query with place-holder parameter 'p'. uniqueQuery' :: UniqueRelation p c r -> QueryUnique (PlaceHolders p, Projection c r) uniqueQuery' = uniqueQueryWithAttr Just' -- | Join unique sub-query with place-holder parameter 'p'. Query result is 'Maybe'. uniqueQueryMaybe' :: UniqueRelation p c r -> QueryUnique (PlaceHolders p, Projection c (Maybe r)) uniqueQueryMaybe' pr = do (ph, pj) <- uniqueQueryWithAttr Maybe pr return (ph, Projection.just pj) -- | Finalize 'QueryUnique' monad and generate 'UniqueRelation'. uniqueRelation' :: QueryUnique (PlaceHolders p, Projection c r) -> UniqueRelation p c r uniqueRelation' = unsafeUnique . unsafeTypeRelation . Unique.toSubQuery -- | Aggregated 'UniqueRelation'. aggregatedUnique :: Relation ph r -> Pi r a -> (Projection Flat a -> Projection Aggregated b) -> UniqueRelation ph Flat b aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do (ph, a) <- query' rel return (ph, ag $ a ! k) -- | Scalar sub-query with place-holder parameter 'p'. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation p c r -> m (PlaceHolders p, Projection c (Maybe r)) queryScalar' ur = unsafeAddPlaceHolders . liftQualify $ Projection.unsafeFromScalarSubQuery <$> untypeRelation (unUnique ur) -- | Scalar sub-query. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> m (Projection c (Maybe r)) queryScalar = fmap snd . queryScalar' relational-query-0.8.3.2/src/Database/Relational/Query/Projectable.hs0000644000000000000000000005402113000574776023640 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Query.Projectable -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines operators on various polymorphic projections. module Database.Relational.Query.Projectable ( -- * Projectable from SQL strings SqlProjectable (unsafeProjectSqlTerms'), unsafeProjectSql', unsafeProjectSqlTerms, unsafeProjectSql, -- * Projections of values value, valueTrue, valueFalse, values, unsafeValueNull, -- * Placeholders PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders, placeholder', placeholder, unitPlaceHolder, -- * Projectable into SQL strings ProjectableShowSql (unsafeShowSql'), unsafeShowSql, -- * Operators (.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.), and', or', in', (.||.), (?||?), like, likeMaybe, like', likeMaybe', (.+.), (.-.), (.*.), (./.), (?+?), (?-?), (?*?), (?/?), isNothing, isJust, fromMaybe, not', exists, negate', fromIntegral', showNum, negateMaybe, fromIntegralMaybe, showNumMaybe, casesOrElse, casesOrElse', caseSearch, caseSearchMaybe, case', caseMaybe, SqlBinOp, unsafeBinOp, unsafeUniOp, -- * Terms for Window function types rank, denseRank, rowNumber, percentRank, cumeDist, -- * Zipping projections projectZip, (><), ProjectableIdZip (..), -- * 'Maybe' type projecitoins ProjectableMaybe (just, flattenMaybe), -- * ProjectableFunctor and ProjectableApplicative ProjectableFunctor (..), ProjectableApplicative (..), ipfmap ) where import Prelude hiding (pi) import Data.String (IsString) import Data.Monoid ((<>), mconcat) import Control.Applicative ((<$>)) import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL import Database.Record (PersistableWidth, PersistableRecordWidth, derivedWidth, HasColumnConstraint, NotNull) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) 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 -- | Interface to project SQL terms unsafely. class SqlProjectable p where -- | Unsafely project from SQL expression terms. unsafeProjectSqlTerms' :: [StringSQL] -- ^ SQL expression strings -> p t -- ^ Result projection object -- | Unsafely project from SQL strings. String interface of 'unsafeProjectSqlTerms''. unsafeProjectSqlTerms :: SqlProjectable p => [String] -- ^ SQL expression strings -> p t -- ^ Result projection object unsafeProjectSqlTerms = unsafeProjectSqlTerms' . map stringSQL -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection Flat) where unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection Aggregated) where unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection OverWindow) where unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms class SqlProjectable p => OperatorProjectable p instance OperatorProjectable (Projection Flat) instance OperatorProjectable (Projection Aggregated) -- | Unsafely Project single SQL term. unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t unsafeProjectSql' = unsafeProjectSqlTerms' . (:[]) -- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql''. unsafeProjectSql :: SqlProjectable p => String -> p t unsafeProjectSql = unsafeProjectSql' . stringSQL -- | Polymorphic projection of SQL null value. unsafeValueNull :: OperatorProjectable p => p (Maybe a) unsafeValueNull = unsafeProjectSql "NULL" -- | Generate polymorphic projection of SQL constant values from Haskell value. value :: (ShowConstantTermsSQL t, OperatorProjectable p) => t -> p t value = unsafeProjectSqlTerms' . showConstantTermsSQL' -- | Polymorphic proejction of SQL true value. valueTrue :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool) valueTrue = just $ value True -- | Polymorphic proejction of SQL false value. valueFalse :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool) valueFalse = just $ value False -- | Polymorphic proejction of SQL set value from Haskell list. values :: (ShowConstantTermsSQL t, OperatorProjectable p) => [t] -> ListProjection p t values = Projection.list . map value -- | Interface to get SQL term from projections. class ProjectableShowSql p where -- | Unsafely generate SQL expression term from projection object. unsafeShowSql' :: p a -- ^ Source projection object -> StringSQL -- ^ Result SQL expression string. -- | Unsafely generate SQL expression string from projection object. -- String interface of 'unsafeShowSql''. unsafeShowSql :: ProjectableShowSql p => p a -- ^ Source projection object -> String -- ^ Result SQL expression string. unsafeShowSql = showStringSQL . unsafeShowSql' -- | Unsafely get SQL term from 'Proejction'. instance ProjectableShowSql (Projection c) where unsafeShowSql' = Projection.unsafeStringSql -- | Binary operator type for SQL String. type SqlBinOp = Keyword -> Keyword -> Keyword -- | Unsafely make projection unary operator from SQL keyword. unsafeUniOp :: (ProjectableShowSql p0, SqlProjectable p1) => (Keyword -> Keyword) -> p0 a -> p1 b unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql' unsafeFlatUniOp :: (SqlProjectable p, ProjectableShowSql p) => Keyword -> p a -> p b unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw) -- | Unsafely make projection binary operator from string binary operator. unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p) => SqlBinOp -> p a -> p b -> p c unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $ op (unsafeShowSql' a) (unsafeShowSql' b) -- | Unsafely make compare projection binary operator from string binary operator. compareBinOp :: (SqlProjectable p, ProjectableShowSql p) => SqlBinOp -> p a -> p a -> p (Maybe Bool) compareBinOp = unsafeBinOp -- | Unsafely make numrical projection binary operator from string binary operator. monoBinOp :: (SqlProjectable p, ProjectableShowSql p) => SqlBinOp -> p a -> p a -> p a monoBinOp = unsafeBinOp -- | Compare operator corresponding SQL /=/ . (.=.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.=.) = compareBinOp (SQL..=.) -- | Compare operator corresponding SQL / p ft -> p ft -> p (Maybe Bool) (.<.) = compareBinOp (SQL..<.) -- | Compare operator corresponding SQL /<=/ . (.<=.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.<=.) = compareBinOp (SQL..<=.) -- | Compare operator corresponding SQL />/ . (.>.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.>.) = compareBinOp (SQL..>.) -- | Compare operator corresponding SQL />=/ . (.>=.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.>=.) = compareBinOp (SQL..>=.) -- | Compare operator corresponding SQL /<>/ . (.<>.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.<>.) = compareBinOp (SQL..<>.) -- | Logical operator corresponding SQL /AND/ . and' :: (OperatorProjectable p, ProjectableShowSql p) => p (Maybe Bool) -> p (Maybe Bool) -> p (Maybe Bool) and' = monoBinOp SQL.and -- | Logical operator corresponding SQL /OR/ . or' :: (OperatorProjectable p, ProjectableShowSql p) => p (Maybe Bool) -> p (Maybe Bool) -> p (Maybe Bool) or' = monoBinOp SQL.or -- | Logical operator corresponding SQL /NOT/ . not' :: (OperatorProjectable p, ProjectableShowSql p) => p (Maybe Bool) -> p (Maybe Bool) not' = unsafeFlatUniOp SQL.NOT -- | Logical operator corresponding SQL /EXISTS/ . exists :: (OperatorProjectable p, ProjectableShowSql p) => ListProjection (Projection Exists) r -> p (Maybe Bool) exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS . Projection.unsafeStringSqlList unsafeShowSql' -- | Concatinate operator corresponding SQL /||/ . (.||.) :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p a -> p a -> p a (.||.) = unsafeBinOp (SQL..||.) -- | Concatinate operator corresponding SQL /||/ . Maybe type version. (?||?) :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?||?) = unsafeBinOp (SQL..||.) unsafeLike :: (OperatorProjectable p, ProjectableShowSql p) => p a -> p b -> p (Maybe Bool) unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE) -- | String-compare operator corresponding SQL /LIKE/ . like' :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p a -> p a -> p (Maybe Bool) x `like'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . likeMaybe' :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p (Maybe a) -> p (Maybe a) -> p (Maybe Bool) x `likeMaybe'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . like :: (OperatorProjectable p, ProjectableShowSql p, IsString a, ShowConstantTermsSQL a) => p a -> a -> p (Maybe Bool) x `like` a = x `like'` value a -- | String-compare operator corresponding SQL /LIKE/ . Maybe type version. likeMaybe :: (OperatorProjectable p, ProjectableShowSql p, IsString a, ShowConstantTermsSQL a) => p (Maybe a) -> a -> p (Maybe Bool) x `likeMaybe` a = x `unsafeLike` value a -- | Unsafely make number projection binary operator from SQL operator string. monoBinOp' :: (SqlProjectable p, ProjectableShowSql p) => Keyword -> p a -> p a -> p a monoBinOp' = monoBinOp . SQL.defineBinOp -- | Number operator corresponding SQL /+/ . (.+.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (.+.) = monoBinOp' "+" -- | Number operator corresponding SQL /-/ . (.-.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (.-.) = monoBinOp' "-" -- | Number operator corresponding SQL /// . (./.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (./.) = monoBinOp' "/" -- | Number operator corresponding SQL /*/ . (.*.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (.*.) = monoBinOp' "*" -- | Number negate uni-operator corresponding SQL /-/. negate' :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a negate' = unsafeFlatUniOp $ SQL.word "-" unsafeCastProjectable :: (SqlProjectable p, ProjectableShowSql p) => p a -> p b unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql' -- | Number fromIntegral uni-operator. fromIntegral' :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b) => p a -> p b fromIntegral' = unsafeCastProjectable -- | Unsafely show number into string-like type in projections. showNum :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b) => p a -> p b showNum = unsafeCastProjectable -- | Number operator corresponding SQL /+/ . (?+?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?+?) = monoBinOp' "+" -- | Number operator corresponding SQL /-/ . (?-?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?-?) = monoBinOp' "-" -- | Number operator corresponding SQL /// . (?/?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?/?) = monoBinOp' "/" -- | Number operator corresponding SQL /*/ . (?*?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?*?) = monoBinOp' "*" -- | Number negate uni-operator corresponding SQL /-/. negateMaybe :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) negateMaybe = unsafeFlatUniOp $ SQL.word "-" -- | Number fromIntegral uni-operator. fromIntegralMaybe :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b) => p (Maybe a) -> p (Maybe b) fromIntegralMaybe = unsafeCastProjectable -- | Unsafely show number into string-like type in projections. showNumMaybe :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b) => p (Maybe a) -> p (Maybe b) showNumMaybe = unsafeCastProjectable whensClause :: (OperatorProjectable p, ProjectableShowSql p) => String -- ^ Error tag -> [(p a, p b)] -- ^ Each when clauses -> p b -- ^ Else result projection -> Keyword -- ^ Result projection whensClause eTag cs0 e = d cs0 where d [] = error $ eTag ++ ": Empty when clauses!" d cs@(_:_) = mconcat [when' p r | (p, r) <- cs] <> else' <> SQL.END when' p r = SQL.WHEN <> unsafeShowSql' p <> SQL.THEN <> unsafeShowSql' r else' = SQL.ELSE <> unsafeShowSql' e -- | Search case operator correnponding SQL search /CASE/. -- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ caseSearch :: (OperatorProjectable p, ProjectableShowSql p) => [(p (Maybe Bool), p a)] -- ^ Each when clauses -> p a -- ^ Else result projection -> p a -- ^ Result projection caseSearch cs e = unsafeProjectSql' $ SQL.CASE <> whensClause "caseSearch" cs e -- | Same as 'caseSearch', but you can write like `casesOrElse` . casesOrElse :: (OperatorProjectable p, ProjectableShowSql p) => [(p (Maybe Bool), p a)] -- ^ Each when clauses -> p a -- ^ Else result projection -> p a -- ^ Result projection casesOrElse = caseSearch -- | Null default version of 'caseSearch'. caseSearchMaybe :: (OperatorProjectable p, ProjectableShowSql p) => [(p (Maybe Bool), p (Maybe a))] -- ^ Each when clauses -> p (Maybe a) -- ^ Result projection caseSearchMaybe cs = caseSearch cs unsafeValueNull -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ case' :: (OperatorProjectable p, ProjectableShowSql p) => p a -- ^ Projection value to match -> [(p a, p b)] -- ^ Each when clauses -> p b -- ^ Else result projection -> p b -- ^ Result projection case' v cs e = unsafeProjectSql' $ SQL.CASE <> unsafeShowSql' v <> whensClause "case'" cs e -- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` . casesOrElse' :: (OperatorProjectable p, ProjectableShowSql p) => (p a, [(p a, p b)]) -- ^ Projection value to match and each when clauses list -> p b -- ^ Else result projection -> p b -- ^ Result projection casesOrElse' = uncurry case' -- | Null default version of 'case''. caseMaybe :: (OperatorProjectable p, ProjectableShowSql p, ProjectableMaybe p) => p a -- ^ Projection value to match -> [(p a, p (Maybe b))] -- ^ Each when clauses -> p (Maybe b) -- ^ Result projection caseMaybe v cs = case' v cs unsafeValueNull -- | Binary operator corresponding SQL /IN/ . in' :: (OperatorProjectable p, ProjectableShowSql p) => p t -> ListProjection p t -> p (Maybe Bool) in' a lp = unsafeProjectSql' . SQL.paren $ SQL.in' (unsafeShowSql' a) (Projection.unsafeStringSqlList unsafeShowSql' lp) -- | Operator corresponding SQL /IS NULL/ , and extended against record types. isNothing :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) => Projection c (Maybe r) -> Projection c (Maybe Bool) isNothing mr = unsafeProjectSql' $ SQL.paren $ (SQL.defineBinOp SQL.IS) (Projection.unsafeStringSqlNotNullMaybe mr) SQL.NULL -- | Operator corresponding SQL /NOT (... IS NULL)/ , and extended against record type. isJust :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) => Projection c (Maybe r) -> Projection c (Maybe Bool) isJust = not' . isNothing -- | Operator from maybe type using record extended 'isNull'. fromMaybe :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) => Projection c r -> Projection c (Maybe r) -> Projection c r fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p unsafeUniTermFunction :: SqlProjectable p => Keyword -> p t unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()") -- | /RANK()/ term. rank :: Integral a => Projection OverWindow a rank = unsafeUniTermFunction SQL.RANK -- | /DENSE_RANK()/ term. denseRank :: Integral a => Projection OverWindow a denseRank = unsafeUniTermFunction SQL.DENSE_RANK -- | /ROW_NUMBER()/ term. rowNumber :: Integral a => Projection OverWindow a rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER -- | /PERCENT_RANK()/ term. percentRank :: Projection OverWindow Double percentRank = unsafeUniTermFunction SQL.PERCENT_RANK -- | /CUME_DIST()/ term. cumeDist :: Projection OverWindow Double cumeDist = unsafeUniTermFunction SQL.CUME_DIST -- | Placeholder parameter type which has real parameter type arguemnt 'p'. data PlaceHolders p = PlaceHolders -- | Unsafely add placeholder parameter to queries. unsafeAddPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a) unsafeAddPlaceHolders = fmap ((,) PlaceHolders) -- | Unsafely get placeholder parameter unsafePlaceHolders :: PlaceHolders p unsafePlaceHolders = PlaceHolders -- | No placeholder semantics unitPlaceHolder :: PlaceHolders () unitPlaceHolder = unsafePlaceHolders -- | Unsafely cast placeholder parameter type. unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b unsafeCastPlaceHolders PlaceHolders = PlaceHolders unsafeProjectPlaceHolder' :: (PersistableWidth r, SqlProjectable p) => (PersistableRecordWidth r, p r) unsafeProjectPlaceHolder' = unsafeProjectSqlTerms' . (`replicate` "?") <$> derivedWidth unsafeProjectPlaceHolder :: (PersistableWidth r, SqlProjectable p) => p r unsafeProjectPlaceHolder = snd unsafeProjectPlaceHolder' -- | Provide scoped placeholder and return its parameter object. placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) -> (PlaceHolders t, a) placeholder' f = (PlaceHolders, f unsafeProjectPlaceHolder) -- | Provide scoped placeholder and return its parameter object. Monadic version. placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a) placeholder f = do let (ph, ma) = placeholder' f a <- ma return (ph, a) -- | Zipping projections. projectZip :: ProjectableApplicative p => p a -> p b -> p (a, b) projectZip pa pb = (,) |$| pa |*| pb -- | Binary operator the same as 'projectZip'. (><) :: ProjectableApplicative p => p a -> p b -> p (a, b) (><) = projectZip -- | Interface to control 'Maybe' of phantom type in projections. class ProjectableMaybe p where -- | Cast projection phantom type into 'Maybe'. just :: p a -> p (Maybe a) -- | Compose nested 'Maybe' phantom type on projection. flattenMaybe :: p (Maybe (Maybe a)) -> p (Maybe a) -- | Control phantom 'Maybe' type in placeholder parameters. instance ProjectableMaybe PlaceHolders where just = unsafeCastPlaceHolders flattenMaybe = unsafeCastPlaceHolders -- | Control phantom 'Maybe' type in projection type 'Projection'. instance ProjectableMaybe (Projection c) where just = Projection.just flattenMaybe = Projection.flattenMaybe -- | Zipping except for identity element laws. class ProjectableApplicative p => ProjectableIdZip p where leftId :: p ((), a) -> p a rightId :: p (a, ()) -> p a -- | Zipping except for identity element laws against placeholder parameter type. instance ProjectableIdZip PlaceHolders where leftId = unsafeCastPlaceHolders rightId = unsafeCastPlaceHolders -- | Weaken functor on projections. class ProjectableFunctor p where -- | Method like 'fmap'. (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b -- | Same as '|$|' other than using inferred record constructor. ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b)) => p a -> p b ipfmap = (|$|) productConstructor -- | Weaken applicative functor on projections. class ProjectableFunctor p => ProjectableApplicative p where -- | Method like '<*>'. (|*|) :: p (a -> b) -> p a -> p b -- | Compose seed of record type 'PlaceHolders'. instance ProjectableFunctor PlaceHolders where _ |$| PlaceHolders = PlaceHolders -- | Compose record type 'PlaceHolders' using applicative style. instance ProjectableApplicative PlaceHolders where pf |*| pa = unsafeCastPlaceHolders (pf >< pa) -- | Compose seed of record type 'Projection'. instance ProjectableFunctor (Projection c) where (|$|) = Projection.pfmap -- | Compose record type 'Projection' using applicative style. instance ProjectableApplicative (Projection c) where (|*|) = Projection.pap -- | Compose seed of projection path 'Pi' which has record result type. instance ProjectableFunctor (Pi a) where (|$|) = Pi.pfmap -- | Compose projection path 'Pi' which has record result type using applicative style. instance ProjectableApplicative (Pi a) where (|*|) = Pi.pap infixl 7 .*., ./., ?*?, ?/? infixl 6 .+., .-., ?+?, ?-? infixl 5 .||., ?||? infixl 4 |$|, |*| infix 4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'` infixr 3 `and'` infixr 2 `or'` infixl 1 >< relational-query-0.8.3.2/src/Database/Relational/Query/Arrow.hs0000644000000000000000000004110013000574776022472 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.Arrow -- Copyright : 2015 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines arrow version combinators which -- improves type-safty on building queries. -- Referencing the local projections may cause to break -- the result query. -- It is possible to controls injection of previous local projections -- by restricting domain type of arrow. This idea is imported from Opaleye: -- -- * -- * -- -- Importing this module instead of "Database.Relational.Query" enables -- to build query using arrow combinators. module Database.Relational.Query.Arrow ( module Database.Relational.Query, all', distinct, query, queryMaybe, query', queryMaybe', queryList, queryList', queryExists, queryExists', queryListU, queryListU', queryScalar, queryScalar', queryScalarU, queryScalarU', uniqueQuery', uniqueQueryMaybe', on, wheres, having, groupBy, placeholder, relation, relation', aggregateRelation, aggregateRelation', uniqueRelation', groupBy', key, key', set, bkey, rollup, cube, groupingSets, orderBy, asc, desc, partitionBy, over, assign, derivedUpdate', derivedUpdate, derivedDelete', derivedDelete, QueryA, QuerySimple, QueryAggregate, QueryUnique, AggregatingSet, AggregatingSetList, AggregatingPowerSet, Orderings, Window, Assignings, AssignStatement, RestrictedStatement, ) where import Control.Category (Category) import Control.Arrow (Arrow, Kleisli (..)) import Database.Record import Database.Relational.Query hiding (all', distinct, query, queryMaybe, query', queryMaybe', queryList, queryList', queryScalar, queryScalar', uniqueQuery', uniqueQueryMaybe', on, wheres, having, groupBy, placeholder, relation, relation', aggregateRelation, aggregateRelation', uniqueRelation', groupBy', key, key', set, bkey, rollup, cube, groupingSets, orderBy, asc, desc, partitionBy, over, derivedUpdate', derivedUpdate, derivedDelete', derivedDelete, QuerySimple, QueryAggregate, QueryUnique, Window) import qualified Database.Relational.Query as Monadic import Database.Relational.Query.Projection (ListProjection) import 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 -- | Arrow to build queries. newtype QueryA m a b = QueryA (Kleisli m a b) deriving (Category, Arrow) queryA :: (a -> m b) -> QueryA m a b queryA = QueryA . Kleisli runQueryA :: QueryA m a b -> a -> m b runQueryA (QueryA k) = runKleisli k runAofM :: (m b -> c) -> QueryA m () b -> c runAofM = (. (`runQueryA` ())) -- | Arrow type corresponding to 'Monadic.QuerySimple' type QuerySimple = QueryA Monadic.QuerySimple -- | Arrow type corresponding to 'Monadic.QueryAggregate' type QueryAggregate = QueryA Monadic.QueryAggregate -- | Arrow type corresponding to 'Monadic.QueryUnique' type QueryUnique = QueryA Monadic.QueryUnique -- | Arrow type corresponding to 'Monadic.AggregatingSet' type AggregatingSet = QueryA Monadic.AggregatingSet -- | Arrow type corresponding to 'Monadic.AggregatingSetList' type AggregatingSetList = QueryA Monadic.AggregatingSetList -- | Arrow type corresponding to 'Monadic.AggregatingPowerSet' type AggregatingPowerSet = QueryA Monadic.AggregatingPowerSet -- | Arrow type corresponding to 'Monadic.Orderings' type Orderings c m = QueryA (Monadic.Orderings c m) -- | Arrow type corresponding to 'Monadic.Window' type Window c = QueryA (Monadic.Window c) -- | Arrow type corresponding to 'Monadic.Assignings' type Assignings r m = QueryA (Monadic.Assignings r m) -- | Arrow type corresponding to 'Monadic.AssignStatement' type AssignStatement r a = Assignings r Restrict (Projection Flat r) a -- | Arrow type corresponding to 'Monadic.RestrictedStatement' type RestrictedStatement r a = QueryA Monadic.Restrict (Projection Flat r) a -- | Same as 'Monadic.all''. Arrow version. all' :: MonadQuery m => QueryA m () () all' = queryA $ \() -> Monadic.all' -- | Same as 'Monadic.distinct'. Arrow version. distinct :: MonadQuery m => QueryA m () () distinct = queryA $ \() -> Monadic.distinct -- | Same as 'Monadic.query'. Arrow version. -- The result arrow is not injected by local projections. query :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> QueryA m () (Projection Flat r) query r = queryA $ \() -> Monadic.query r -- | Same as 'Monadic.queryMaybe'. Arrow version. -- The result arrow is not injected by any local projections. queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> QueryA m () (Projection Flat (Maybe r)) queryMaybe r = queryA $ \() -> Monadic.queryMaybe r -- | Same as 'Monadic.query''. Arrow version. -- The result arrow is not injected by any local projections. query' :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation p r -> QueryA m () (PlaceHolders p, Projection Flat r) query' r = queryA $ \() -> Monadic.query' r -- | Same as 'Monadic.queryMaybe''. Arrow version. -- The result arrow is not injected by any local projections. queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation p r -> QueryA m () (PlaceHolders p, Projection Flat (Maybe r)) queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r unsafeQueryList :: MonadQualify ConfigureQuery m => (a -> Relation () r) -> QueryA m a (ListProjection (Projection c) r) unsafeQueryList rf = queryA $ Monadic.queryList . rf unsafeQueryList' :: MonadQualify ConfigureQuery m => (a -> Relation p r) -> QueryA m a (PlaceHolders p, ListProjection (Projection c) r) unsafeQueryList' rf = queryA $ Monadic.queryList' . rf -- | Same as 'Monadic.queryList'. Arrow version. -- The result arrow is designed to be injected by local projections. queryList :: MonadQualify ConfigureQuery m => (Projection c a -> Relation () r) -> QueryA m (Projection c a) (ListProjection (Projection c) r) queryList = unsafeQueryList -- | Same as 'Monadic.queryList''. Arrow version. -- The result arrow is designed to be injected by local projections. queryList' :: MonadQualify ConfigureQuery m => (Projection c a -> Relation p r) -> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection c) r) queryList' = unsafeQueryList' -- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version. -- The result arrow is designed to be injected by local projections. queryExists :: MonadQualify ConfigureQuery m => (Projection c a -> Relation () r) -> QueryA m (Projection c a) (ListProjection (Projection Exists) r) queryExists = unsafeQueryList -- | Same as 'Monadic.queryList'' to pass this result to 'exists' operator. Arrow version. -- The result arrow is designed to be injected by local projections. queryExists' :: MonadQualify ConfigureQuery m => (Projection c a -> Relation p r) -> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection Exists) r) queryExists' = unsafeQueryList' -- | Same as 'Monadic.queryList'. Arrow version. -- Useful for no reference cases to local projections. queryListU :: MonadQualify ConfigureQuery m => Relation () r -> QueryA m () (ListProjection (Projection c) r) queryListU r = unsafeQueryList $ \() -> r -- | Same as 'Monadic.queryList''. Arrow version. -- Useful for no reference cases to local projections. queryListU' :: MonadQualify ConfigureQuery m => Relation p r -> QueryA m () (PlaceHolders p, ListProjection (Projection c) r) queryListU' r = unsafeQueryList' $ \() -> r unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (a -> UniqueRelation () c r) -> QueryA m a (Projection c (Maybe r)) unsafeQueryScalar rf = queryA $ Monadic.queryScalar . rf unsafeQueryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (a -> UniqueRelation p c r) -> QueryA m a (PlaceHolders p, Projection c (Maybe r)) unsafeQueryScalar' rf = queryA $ Monadic.queryScalar' . rf -- | Same as 'Monadic.queryScalar'. Arrow version. -- The result arrow is designed to be injected by any local projection. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (Projection c a -> UniqueRelation () c r) -> QueryA m (Projection c a) (Projection c (Maybe r)) queryScalar = unsafeQueryScalar -- | Same as 'Monadic.queryScalar''. Arrow version. -- The result arrow is designed to be injected by any local projection. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (Projection c a -> UniqueRelation p c r) -> QueryA m (Projection c a) (PlaceHolders p, Projection c (Maybe r)) queryScalar' = unsafeQueryScalar' -- | Same as 'Monadic.queryScalar'. Arrow version. -- Useful for no reference cases to local projections. queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> QueryA m () (Projection c (Maybe r)) queryScalarU r = unsafeQueryScalar $ \() -> r -- | Same as 'Monadic.queryScalar''. Arrow version. -- Useful for no reference cases to local projections. queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation p c r -> QueryA m () (PlaceHolders p, Projection c (Maybe r)) queryScalarU' r = unsafeQueryScalar' $ \() -> r -- | Same as 'Monadic.uniqueQuery''. Arrow version. -- The result arrow is not injected by local projections. uniqueQuery' :: UniqueRelation p c r -> QueryA Monadic.QueryUnique () (PlaceHolders p, Projection c r) uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r -- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version. -- The result arrow is not injected by local projections. uniqueQueryMaybe' :: UniqueRelation p c r -> QueryA Monadic.QueryUnique () (PlaceHolders p, Projection c (Maybe r)) uniqueQueryMaybe' r = queryA $ \() -> Monadic.uniqueQueryMaybe' r -- | Same as 'Monadic.on'. Arrow version. -- The result arrow is designed to be injected by local conditional flat-projections. on :: MonadQuery m => QueryA m (Projection Flat (Maybe Bool)) () on = queryA Monadic.on -- | Same as 'Monadic.wheres'. Arrow version. -- The result arrow is designed to be injected by local conditional flat-projections. wheres :: MonadRestrict Flat m => QueryA m (Projection Flat (Maybe Bool)) () wheres = queryA Monadic.wheres -- | Same as 'Monadic.having'. Arrow version. -- The result arrow is designed to be injected by local conditional aggregated-projections. having :: MonadRestrict Aggregated m => QueryA m (Projection Aggregated (Maybe Bool)) () having = queryA Monadic.having -- | Same as 'Monadic.groupBy'. Arrow version. -- The result arrow is designed to be injected by local flat-projections. groupBy :: MonadAggregate m => QueryA m (Projection Flat r) (Projection Aggregated r) groupBy = queryA Monadic.groupBy -- | Same as 'Monadic.placeholder'. Arrow version. -- The result arrow is designed to be injected by locally built arrow using placeholders. placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => QueryA m (QueryA m (p t) a) (PlaceHolders t, a) placeholder = queryA $ Monadic.placeholder . runQueryA -- | Same as 'Monadic.relation'. -- Finalize query-building arrow instead of query-building monad. relation :: QuerySimple () (Projection Flat r) -> Relation () r relation = runAofM Monadic.relation -- | Same as 'Monadic.relation''. -- Finalize query-building arrow instead of query-building monad. relation' :: QuerySimple () (PlaceHolders p, Projection Flat r) -> Relation p r relation' = runAofM Monadic.relation' -- | Same as 'Monadic.aggregateRelation'. -- Finalize query-building arrow instead of query-building monad. aggregateRelation :: QueryAggregate () (Projection Aggregated r) -> Relation () r aggregateRelation = runAofM Monadic.aggregateRelation -- | Same as 'Monadic.aggregateRelation''. -- Finalize query-building arrow instead of query-building monad. aggregateRelation' :: QueryAggregate () (PlaceHolders p, Projection Aggregated r) -> Relation p r aggregateRelation' = runAofM Monadic.aggregateRelation' -- | Same as 'Monadic.uniqueRelation''. -- Finalize query-building arrow instead of query-building monad. uniqueRelation' :: QueryUnique () (PlaceHolders p, Projection c r) -> UniqueRelation p c r uniqueRelation' = runAofM Monadic.uniqueRelation' -- | Same as 'Monadic.groupBy''. -- This arrow is designed to be injected by local 'AggregateKey'. groupBy' :: MonadAggregate m => QueryA m (AggregateKey (Projection Aggregated r)) (Projection Aggregated r) groupBy' = queryA Monadic.groupBy' -- | Same as 'Monadic.key'. -- This arrow is designed to be injected by local flat-projections. key :: AggregatingSet (Projection Flat r) (Projection Aggregated (Maybe r)) key = queryA Monadic.key -- | Same as 'Monadic.key''. -- This arrow is designed to be injected by local 'AggregteKey'. key' :: AggregatingSet (AggregateKey a) a key' = queryA Monadic.key' -- | Same as 'Monadic.set'. -- This arrow is designed to be injected by locally built 'AggregtingSet' arrow. set :: AggregatingSetList (AggregatingSet () a) a set = queryA $ runAofM Monadic.set -- | Same as 'Monadic.bkey'. -- This arrow is designed to be injected by local flat-projections. bkey :: AggregatingPowerSet (Projection Flat r) (Projection Aggregated (Maybe r)) bkey = queryA Monadic.bkey -- | Same as 'Monadic.rollup'. -- Finalize locally built 'AggregatingPowerSet'. rollup :: AggregatingPowerSet () a -> AggregateKey a rollup = runAofM Monadic.rollup -- | Same as 'Monadic.cube'. -- Finalize locally built 'AggregatingPowerSet'. cube :: AggregatingPowerSet () a -> AggregateKey a cube = runAofM Monadic.cube -- | Same as 'Monadic.groupingSets'. -- Finalize locally built 'AggregatingSetList'. groupingSets :: AggregatingSetList () a -> AggregateKey a groupingSets = runAofM Monadic.groupingSets -- | Same as 'Monadic.orderBy'. -- The result arrow is designed to be injected by local projections. orderBy :: Monad m => Order -> Orderings c m (Projection c t) () orderBy o = queryA (`Monadic.orderBy` o) -- | Same as 'Monadic.asc'. -- The result arrow is designed to be injected by local projections. asc :: Monad m => Orderings c m (Projection c t) () asc = queryA Monadic.asc -- | Same as 'Monadic.desc'. -- The result arrow is designed to be injected by local projections. desc :: Monad m => Orderings c m (Projection c t) () desc = queryA Monadic.desc -- | Same as 'Monadic.partitionBy'. -- The result arrow is designed to be injected by local projections. partitionBy :: Window c (Projection c r) () partitionBy = queryA Monadic.partitionBy -- | Same as 'Monadic.over'. -- Make window function result projection using built 'Window' arrow. over :: SqlProjectable (Projection c) => Projection OverWindow a -> Window c () () -> Projection c a over po = runAofM $ Monadic.over po infix 8 `over` -- | Make 'Monadic.AssignTarget' into arrow which is designed to be -- injected by local projection assignees. assign :: Monad m => Monadic.AssignTarget r v -> Assignings r m (Projection Flat v) () assign t = queryA (`Monadic.assignTo` t) -- | Same as 'Monadic.derivedUpdate''. -- Make 'Update' from assigning statement arrow using configuration. derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p derivedUpdate' config = Monadic.derivedUpdate' config . runQueryA -- | Same as 'Monadic.derivedUpdate'. -- Make 'Update' from assigning statement arrow. derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p derivedUpdate = Monadic.derivedUpdate . runQueryA -- | Same as 'Monadic.derivedDelete''. -- Make 'Update' from restrict statement arrow using configuration. derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete' config = Monadic.derivedDelete' config . runQueryA -- | Same as 'Monadic.derivedDelete'. -- Make 'Update' from restrict statement arrow. derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete = Monadic.derivedDelete . runQueryA relational-query-0.8.3.2/src/Database/Relational/Query/Effect.hs0000644000000000000000000001505313000574776022604 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Effect -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines effect statements -- like update and delete. module Database.Relational.Query.Effect ( -- * Object to express simple restriction. Restriction, restriction, restriction', -- * Object to express update target columns and restriction. UpdateTarget, updateTarget, updateTarget', liftTargetAllColumn, liftTargetAllColumn', updateTargetAllColumn, updateTargetAllColumn', -- * Object to express insert terget. InsertTarget, insertTarget, insertTarget', -- * Generate SQL from restriction. sqlWhereFromRestriction, sqlFromUpdateTarget, sqlFromInsertTarget ) where import Data.Monoid ((<>)) import Database.Record (PersistableWidth) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) 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 import Database.Relational.Query.Monad.Assign (AssignStatement) 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'. newtype Restriction p r = Restriction (RestrictedStatement r (PlaceHolders p)) -- | Finalize 'Restrict' monad and generate 'Restriction'. restriction :: RestrictedStatement r () -> Restriction () r restriction = Restriction . ((>> return unitPlaceHolder) .) -- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p' restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r restriction' = Restriction runRestriction :: Restriction p r -> RestrictedStatement r (PlaceHolders p) runRestriction (Restriction qf) = fmap fst . unsafeAddPlaceHolders . qf -- | SQL WHERE clause 'StringSQL' string from 'Restriction'. sqlWhereFromRestriction :: Config -> Table r -> Restriction p r -> StringSQL sqlWhereFromRestriction config tbl (Restriction q) = composeWhere rs where (_ph, rs) = Restrict.extract (q $ Projection.unsafeFromTable tbl) config -- | Show where clause. instance TableDerivable r => Show (Restriction p r) where show = showStringSQL . sqlWhereFromRestriction defaultConfig derivedTable -- | UpdateTarget type with place-holder parameter 'p' and projection record type 'r'. newtype UpdateTarget p r = UpdateTarget (AssignStatement r (PlaceHolders p)) -- | Finalize 'Target' monad and generate 'UpdateTarget'. updateTarget :: AssignStatement r () -> UpdateTarget () r updateTarget = UpdateTarget . ((>> return unitPlaceHolder) .) -- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'. updateTarget' :: AssignStatement r (PlaceHolders p) -> UpdateTarget p r updateTarget' = UpdateTarget _runUpdateTarget :: UpdateTarget p r -> AssignStatement r (PlaceHolders p) _runUpdateTarget (UpdateTarget qf) = fmap fst . unsafeAddPlaceHolders . qf updateAllColumn :: PersistableWidth r => Restriction p r -> AssignStatement r (PlaceHolders (r, p)) updateAllColumn rs proj = do (ph0, ()) <- placeholder (\ph -> id' <-# ph) ph1 <- assignings $ runRestriction rs proj return $ ph0 >< ph1 -- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. liftTargetAllColumn :: PersistableWidth r => Restriction () r -> UpdateTarget r r liftTargetAllColumn rs = updateTarget' $ \proj -> fmap rightId $ updateAllColumn rs proj -- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. With placefolder type 'p'. liftTargetAllColumn' :: PersistableWidth r => Restriction p r -> UpdateTarget (r, p) r liftTargetAllColumn' rs = updateTarget' $ updateAllColumn rs -- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. updateTargetAllColumn :: PersistableWidth r => RestrictedStatement r () -> UpdateTarget r r updateTargetAllColumn = liftTargetAllColumn . restriction -- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'. updateTargetAllColumn' :: PersistableWidth r => RestrictedStatement r (PlaceHolders p) -> UpdateTarget (r, p) r updateTargetAllColumn' = liftTargetAllColumn' . restriction' -- | SQL SET clause and WHERE clause 'StringSQL' string from 'UpdateTarget' sqlFromUpdateTarget :: Config -> Table r -> UpdateTarget p r -> StringSQL sqlFromUpdateTarget config tbl (UpdateTarget q) = composeSets (asR tbl) <> composeWhere rs where ((_ph, asR), rs) = Assign.extract (q (Projection.unsafeFromTable tbl)) config instance TableDerivable r => Show (UpdateTarget p r) where show = showStringSQL . sqlFromUpdateTarget defaultConfig derivedTable -- | InsertTarget type with place-holder parameter 'p' and projection record type 'r'. newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p)) -- | Finalize 'Register' monad and generate 'InsertTarget'. insertTarget :: Register r () -> InsertTarget () r insertTarget = InsertTarget . (>> return unitPlaceHolder) -- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'. insertTarget' :: Register r (PlaceHolders p) -> InsertTarget p r insertTarget' = InsertTarget -- | SQL INSERT statement 'StringSQL' string from 'InsertTarget' sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL sqlFromInsertTarget config tbl (InsertTarget q) = INSERT <> INTO <> stringSQL (Table.name tbl) <> composeValues (asR tbl) where (_ph, asR) = Register.extract q config relational-query-0.8.3.2/src/Database/Relational/Query/Pi.hs0000644000000000000000000000223013000574776021751 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Pi -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed projection path objects. -- Contains normal interfaces. module Database.Relational.Query.Pi ( -- * Projection path Pi, pfmap, pap, (<.>), (), (), id', fst', snd' ) where import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Query.Pi.Unsafe (Pi, pfmap, pap, (<.>), (), (), definePi) -- | Identity projection path. id' :: PersistableWidth a => Pi a a id' = definePi 0 -- | Projection path for fst of tuple. fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst. fst' = definePi 0 snd'' :: PersistableWidth b => PersistableRecordWidth a -> Pi (a, b) b snd'' wa = definePi (runPersistableRecordWidth wa) -- | Projection path for snd of tuple. snd' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) b -- ^ Projection path of snd. snd' = snd'' persistableWidth relational-query-0.8.3.2/src/Database/Relational/Query/Monad/0000755000000000000000000000000013000574776022106 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Assign.hs0000644000000000000000000000334113000574776023667 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Assign -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about restrict context with assignment monad type. module Database.Relational.Query.Monad.Assign ( -- * Monad to restrict target records with assignment. Assign, AssignStatement, -- updateStatement, extract, ) where 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) import Database.Relational.Query.Monad.Restrict (Restrict) 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 -- | AssignStatement type synonym. -- Specifying assignments and restrictions like update statement. -- Projection record type must be -- the same as 'Target' type parameter 'r'. type AssignStatement r a = Projection Flat r -> Assign r a -- -- | 'return' of 'Update' -- updateStatement :: a -> Assignings r (Restrictings Identity) a -- updateStatement = assignings . restrictings . Identity -- | Run 'Assign'. extract :: Assign r a -> Config -> ((a, Table r -> Assignments), QueryRestriction Flat) extract = Restrict.extract . extractAssignments relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Unique.hs0000644000000000000000000000475013000574776023716 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.Monad.Unique -- Copyright : 2014-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about unique query type -- to support scalar queries. module Database.Relational.Query.Monad.Unique ( QueryUnique, unsafeUniqueSubQuery, toSubQuery, ) where import Control.Applicative (Applicative) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection 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) -- | Unique query monad type. newtype QueryUnique a = QueryUnique (QueryCore a) deriving (MonadQualify ConfigureQuery, MonadQuery, Monad, Applicative, Functor) -- | Unsafely join sub-query with this unique query. unsafeUniqueSubQuery :: NodeAttr -- ^ Attribute maybe or just -> Qualified SubQuery -- ^ 'SubQuery' to join -> QueryUnique (Projection c r) -- ^ Result joined context and 'SubQuery' result projection. unsafeUniqueSubQuery a = QueryUnique . restrictings . unsafeSubQueryWithAttr a extract :: QueryUnique a -> ConfigureQuery (((a, QueryRestriction Flat), JoinProduct), Duplication) extract (QueryUnique c) = extractCore c -- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. toSubQuery :: QueryUnique (PlaceHolders p, Projection c r) -- ^ 'QueryUnique' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation toSubQuery q = do ((((_ph, pj), rs), pd), da) <- extract q c <- askConfig return $ flatSubQuery c (Projection.untype pj) da pd rs [] relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Register.hs0000644000000000000000000000172513000574776024233 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Monad.Register -- Copyright : 2015 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about assignment monad type to build insert statement. module Database.Relational.Query.Monad.Register ( -- * Monad to register target records. Register, extract, ) where import Database.Relational.Query.Component (Config, Assignments) import Database.Relational.Query.Table (Table) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, configureQuery) import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments) -- | Target register monad type used from insert statement. type Register r = Assignings r ConfigureQuery -- | Run 'InsertStatement'. extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> Assignments) extract = configureQuery . extractAssignments relational-query-0.8.3.2/src/Database/Relational/Query/Monad/BaseType.hs0000644000000000000000000000601513000574776024160 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Monad.BaseType -- Copyright : 2015 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines base monad type to build queries. module Database.Relational.Query.Monad.BaseType ( -- * Base monad type to build queries ConfigureQuery, configureQuery, qualifyQuery, askConfig, -- * Relation type Relation, unsafeTypeRelation, untypeRelation, dump, sqlFromRelationWith, sqlFromRelation, rightPh, leftPh, ) where import Data.Functor.Identity (Identity, runIdentity) import Control.Applicative ((<$>)) import Database.Relational.Query.Component (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) import Database.Relational.Query.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig) -- | Thin monad type for untyped structure. type ConfigureQuery = Qualify (QueryConfig Identity) -- | Run 'ConfigureQuery' monad with initial state to get only result. configureQuery :: ConfigureQuery q -> Config -> q configureQuery cq c = runIdentity $ runQueryConfig (evalQualifyPrime cq) c -- | Get qualifyed table form query. qualifyQuery :: a -> ConfigureQuery (Qualified a) qualifyQuery = Qualify.qualifyQuery -- | Read configuration. askConfig :: ConfigureQuery Config askConfig = qualify askQueryConfig -- | Relation type with place-holder parameter 'p' and query result type 'r'. newtype Relation p r = SubQuery (ConfigureQuery SubQuery) -- | Unsafely type qualified subquery into record typed relation type. unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r unsafeTypeRelation = SubQuery -- | Sub-query Qualify monad from relation. untypeRelation :: Relation p r -> ConfigureQuery SubQuery untypeRelation (SubQuery qsub) = qsub unsafeCastPlaceHolder :: Relation a r -> Relation b r unsafeCastPlaceHolder (SubQuery qsub) = SubQuery qsub -- | Simplify placeholder type applying left identity element. rightPh :: Relation ((), p) r -> Relation p r rightPh = unsafeCastPlaceHolder -- | Simplify placeholder type applying right identity element. leftPh :: Relation (p, ()) r -> Relation p r leftPh = unsafeCastPlaceHolder -- | Generate SQL string from 'Relation' with configuration. sqlFromRelationWith :: Relation p r -> Config -> StringSQL sqlFromRelationWith = configureQuery . (showSQL <$>) . untypeRelation -- | SQL string from 'Relation'. sqlFromRelation :: Relation p r -> StringSQL sqlFromRelation = (`sqlFromRelationWith` defaultConfig) -- | Dump internal structure tree. dump :: Relation p r -> String dump = show . (`configureQuery` defaultConfig) . untypeRelation instance Show (Relation p r) where show = showStringSQL . sqlFromRelation relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Aggregate.hs0000644000000000000000000001001713000574776024327 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Aggregate -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about aggregated query type. module Database.Relational.Query.Monad.Aggregate ( -- * Aggregated Query QueryAggregate, AggregatedQuery, toSQL, toSubQuery, Window, over ) where import Data.Functor.Identity (Identity (runIdentity)) import Data.Monoid ((<>)) 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) import Database.Relational.Query.Monad.Trans.Aggregating (extractAggregateTerms, AggregatingSetT, PartitioningSet) import Database.Relational.Query.Monad.Trans.Ordering (Orderings, extractOrderingTerms) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Query.Monad.Type (QueryCore, extractCore, OrderedQuery) -- | Aggregated query monad type. type QueryAggregate = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) -- | Aggregated query type. 'AggregatedQuery' p r == 'QueryAggregate' ('PlaceHolders' p, 'Projection' 'Aggregated' r). type AggregatedQuery p r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) p r -- | Partition monad type for partition-by clause. type Window c = Orderings c (PartitioningSet c) -- | Restricted 'MonadRestrict' instance. instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where restrict = restrictings . restrict extract :: AggregatedQuery p r -> ConfigureQuery (((((((PlaceHolders p, Projection Aggregated r), OrderingTerms), QueryRestriction Aggregated), [AggregateElem]), QueryRestriction Flat), JoinProduct), Duplication) extract = extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms -- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation. toSQL :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run -> ConfigureQuery String -- ^ Result SQL string with 'ConfigureQuery' computation toSQL = fmap SubQuery.toSQL . toSubQuery -- | Run 'AggregatedQuery' to get 'SubQuery' with 'ConfigureQuery' computation. toSubQuery :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation toSubQuery q = do (((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q c <- askConfig return $ aggregatedSubQuery c (Projection.untype pj) da pd rs ag grs ot extractWindow :: Window c a -> ((a, OrderingTerms), [AggregateColumnRef]) extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms -- | Operator to make window function result projection using built 'Window' monad. over :: SqlProjectable (Projection c) => Projection OverWindow a -> Window c () -> Projection c a wp `over` win = Projection.unsafeFromSqlTerms [ showsColumnSQL c <> composeOver pt ot | c <- Projection.columns wp ] where (((), ot), pt) = extractWindow win infix 8 `over` relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Type.hs0000644000000000000000000000301513000574776023362 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Monad.Type -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines core query type. module Database.Relational.Query.Monad.Type ( -- * Core query monad QueryCore, extractCore, OrderedQuery, ) where import Database.Relational.Query.Component (Duplication) import Database.Relational.Query.Sub (JoinProduct, QueryRestriction) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.BaseType (ConfigureQuery) import Database.Relational.Query.Monad.Trans.Join (QueryJoin, extractProduct) import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict) import Database.Relational.Query.Monad.Trans.Ordering (Orderings) -- | Core query monad type used from flat(not-aggregated) query and aggregated query. type QueryCore = Restrictings Flat (QueryJoin ConfigureQuery) -- | Extract 'QueryCore' computation. extractCore :: QueryCore a -> ConfigureQuery (((a, QueryRestriction Flat), JoinProduct), Duplication) extractCore = extractProduct . extractRestrict -- | OrderedQuery monad type with placeholder type 'p'. Projection must be the same as 'Orderings' context type parameter 'c'. type OrderedQuery c m p r = Orderings c m (PlaceHolders p, Projection c r) relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Simple.hs0000644000000000000000000000515313000574776023677 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Simple -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about simple (not-aggregated) query type. module Database.Relational.Query.Monad.Simple ( -- * Simple query QuerySimple, SimpleQuery, simple, toSQL, toSubQuery, ) where import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Monad.Trans.Join (join') import Database.Relational.Query.Monad.Trans.Restricting (restrictings) import Database.Relational.Query.Monad.Trans.Ordering (Orderings, orderings, extractOrderingTerms) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig) 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 -- | Simple (not-aggregated) query monad type. type QuerySimple = Orderings Flat QueryCore -- | Simple (not-aggregated) query type. 'SimpleQuery'' p r == 'QuerySimple' ('PlaceHolders' p, 'Projection' r). type SimpleQuery p r = OrderedQuery Flat QueryCore p r -- | Lift from qualified table forms into 'QuerySimple'. simple :: ConfigureQuery a -> QuerySimple a simple = orderings . restrictings . join' extract :: SimpleQuery p r -> ConfigureQuery (((((PlaceHolders p, Projection Flat r), OrderingTerms), QueryRestriction Flat), JoinProduct), Duplication) extract = extractCore . extractOrderingTerms -- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation. toSQL :: SimpleQuery p r -- ^ 'SimpleQuery' to run -> ConfigureQuery String -- ^ Result SQL string with 'Qualify' computation toSQL = fmap SubQuery.toSQL . toSubQuery -- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. toSubQuery :: SimpleQuery p r -- ^ 'SimpleQuery'' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation toSubQuery q = do (((((_ph, pj), ot), rs), pd), da) <- extract q c <- askConfig return $ flatSubQuery c (Projection.untype pj) da pd rs ot relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Class.hs0000644000000000000000000000743013000574776023513 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Class -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines query building interface classes. module Database.Relational.Query.Monad.Class ( -- * Query interface classes MonadQualify (..), MonadRestrict (..), MonadQuery (..), MonadAggregate (..), MonadPartition (..), all', distinct, on, wheres, having, ) where 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) -- | Restrict context interface class (Functor m, Monad m) => MonadRestrict c m where -- | Add restriction to this context. restrict :: Projection c (Maybe Bool) -- ^ 'Projection' which represent restriction -> m () -- ^ Restricted query context -- | Query building interface. class (Functor m, Monad m, MonadQualify ConfigureQuery m) => MonadQuery m where -- | Specify duplication. setDuplication :: Duplication -> m () -- | Add restriction to last join. restrictJoin :: Projection Flat (Maybe Bool) -- ^ 'Projection' which represent restriction -> m () -- ^ Restricted query context {- Haddock BUG? -} -- | Join sub-query with place-holder parameter 'p'. query result is not 'Maybe'. query' :: Relation p r -> m (PlaceHolders p, Projection Flat r) -- | Join sub-query with place-holder parameter 'p'. Query result is 'Maybe'. queryMaybe' :: Relation p r -> m (PlaceHolders p, Projection Flat (Maybe r)) -- | Lift interface from base qualify monad. class (Functor q, Monad q, Functor m, Monad m) => MonadQualify q m where -- | Lift from qualify monad 'q' into 'MonadQuery' m. -- Qualify monad qualifies table form 'SubQuery'. liftQualify :: q a -> m a instance (Functor q, Monad q) => MonadQualify q q where liftQualify = id -- | Aggregated query building interface extends 'MonadQuery'. class MonadQuery m => MonadAggregate m where -- | Add /GROUP BY/ term into context and get aggregated projection. groupBy :: Projection Flat r -- ^ Projection to add into group by -> m (Projection Aggregated r) -- ^ Result context and aggregated projection -- | Add /GROUP BY/ term into context and get aggregated projection. Non-traditional group-by version. groupBy' :: AggregateKey (Projection Aggregated r) -- ^ Key to aggretate for non-traditional group-by interface -> m (Projection Aggregated r) -- ^ Result context and aggregated projection -- | Window specification building interface. class Monad m => MonadPartition c m where -- | Add /PARTITION BY/ term into context. partitionBy :: Projection c r -> m () -- | Specify ALL attribute to query context. all' :: MonadQuery m => m () all' = setDuplication All -- | Specify DISTINCT attribute to query context. distinct :: MonadQuery m => m () distinct = setDuplication Distinct -- | Add restriction to last join. Projection type version. on :: MonadQuery m => Projection Flat (Maybe Bool) -> m () on = restrictJoin -- | Add restriction to this not aggregated query. wheres :: MonadRestrict Flat m => Projection Flat (Maybe Bool) -> m () wheres = restrict -- | Add restriction to this aggregated query. Aggregated Projection type version. having :: MonadRestrict Aggregated m => Projection Aggregated (Maybe Bool) -> m () having = restrict relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Restrict.hs0000644000000000000000000000300713000574776024241 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Restrict -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about simple restrict context monad type. module Database.Relational.Query.Monad.Restrict ( -- * Monad to restrict target records. Restrict, RestrictedStatement, -- restricted, extract ) where 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 (Restrictings, extractRestrict) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, configureQuery) -- | Restrict only monad type used from update statement and delete statement. type Restrict = Restrictings Flat ConfigureQuery -- | RestrictedStatement type synonym. -- Projection record type 'r' must be -- the same as 'Restrictings' type parameter 'r'. type RestrictedStatement r a = Projection Flat r -> Restrict a -- -- | 'return' of 'Restrict' -- restricted :: a -> Restrict a -- restricted = restrict . Identity -- | Run 'Restrict' to get 'QueryRestriction'. extract :: Restrict a -> Config -> (a, QueryRestriction Flat) extract = configureQuery . extractRestrict relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/0000755000000000000000000000000013000574776023175 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Aggregating.hs0000644000000000000000000001446713000574776025764 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Aggregating -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift -- from 'MonadQuery' into Aggregated query. module Database.Relational.Query.Monad.Trans.Aggregating ( -- * Transformer into aggregated query Aggregatings, aggregatings, AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT, -- * Result extractAggregateTerms, -- * Grouping sets support AggregatingSet, AggregatingPowerSet, AggregatingSetList, PartitioningSet, key, key', set, bkey, rollup, cube, groupingSets, ) where import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) import Control.Arrow (second) import Data.DList (DList, toList) import Data.Functor.Identity (Identity (runIdentity)) import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList) import Database.Relational.Query.Component (AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets, AggregateKey, aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey) 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(..)) -- | Type to accumulate aggregating context. -- Type 'ac' is aggregating-context type like aggregating key set building, -- aggregating key sets set building and partition key set building. -- Type 'at' is aggregating term type. newtype Aggregatings ac at m a = Aggregatings (WriterT (DList at) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Aggregatings'. aggregatings :: Monad m => m a -> Aggregatings ac at m a aggregatings = lift -- | Context type building one grouping set. type AggregatingSetT = Aggregatings Set AggregateElem -- | Context type building grouping sets list. type AggregatingSetListT = Aggregatings SetList AggregateSet -- | Context type building power group set. type AggregatingPowerSetT = Aggregatings Power AggregateBitKey -- | Context type building partition keys set. type PartitioningSetT c = Aggregatings c AggregateColumnRef -- | Aggregated 'MonadRestrict'. instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where restrict = aggregatings . restrict -- | Aggregated 'MonadQualify'. instance MonadQualify q m => MonadQualify q (AggregatingSetT m) where liftQualify = aggregatings . liftQualify -- | Aggregated 'MonadQuery'. instance MonadQuery m => MonadQuery (AggregatingSetT m) where setDuplication = aggregatings . setDuplication restrictJoin = aggregatings . restrictJoin query' = aggregatings . query' queryMaybe' = aggregatings . queryMaybe' unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m () unsafeAggregateWithTerm = Aggregatings . tell . pure aggregateKey :: Monad m => AggregateKey a -> Aggregatings ac AggregateElem m a aggregateKey k = do unsafeAggregateWithTerm $ aggregateKeyElement k return $ aggregateKeyProjection k -- | Aggregated query instance. instance MonadQuery m => MonadAggregate (AggregatingSetT m) where groupBy p = do mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p] return $ Projection.unsafeToAggregated p groupBy' = aggregateKey -- | Partition clause instance instance Monad m => MonadPartition c (PartitioningSetT c m) where partitionBy = mapM_ unsafeAggregateWithTerm . Projection.columns -- | Run 'Aggregatings' to get terms list. extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at]) extractAggregateTerms (Aggregatings ac) = second toList <$> runWriterT ac extractTermList :: Aggregatings ac at Identity a -> (a, [at]) extractTermList = runIdentity . extractAggregateTerms -- | Context monad type to build single grouping set. type AggregatingSet = AggregatingSetT Identity -- | Context monad type to build grouping power set. type AggregatingPowerSet = AggregatingPowerSetT Identity -- | Context monad type to build grouping set list. type AggregatingSetList = AggregatingSetListT Identity -- | Context monad type to build partition keys set. type PartitioningSet c = PartitioningSetT c Identity -- | Specify key of single grouping set from Projection. key :: Projection Flat r -> AggregatingSet (Projection Aggregated (Maybe r)) key p = do mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p] return . Projection.just $ Projection.unsafeToAggregated p -- | Specify key of single grouping set. key' :: AggregateKey a -> AggregatingSet a key' = aggregateKey -- | Finalize and specify single grouping set. set :: AggregatingSet a -> AggregatingSetList a set s = do let (p, c) = second aggregateGroupingSet . extractTermList $ s unsafeAggregateWithTerm c return p -- | Specify key of rollup and cube power set. bkey :: Projection Flat r -> AggregatingPowerSet (Projection Aggregated (Maybe r)) bkey p = do unsafeAggregateWithTerm . aggregatePowerKey $ Projection.columns p return . Projection.just $ Projection.unsafeToAggregated p finalizePower :: ([AggregateBitKey] -> AggregateElem) -> AggregatingPowerSet a -> AggregateKey a finalizePower finalize pow = unsafeAggregateKey . second finalize . extractTermList $ pow -- | Finalize grouping power set as rollup power set. rollup :: AggregatingPowerSet a -> AggregateKey a rollup = finalizePower aggregateRollup -- | Finalize grouping power set as cube power set. cube :: AggregatingPowerSet a -> AggregateKey a cube = finalizePower aggregateCube -- | Finalize grouping set list. groupingSets :: AggregatingSetList a -> AggregateKey a groupingSets = unsafeAggregateKey . second aggregateSets . extractTermList relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Ordering.hs0000644000000000000000000000776113000574776025315 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Ordering -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift -- from query into query with ordering. module Database.Relational.Query.Monad.Trans.Ordering ( -- * Transformer into query with ordering Orderings, orderings, OrderingTerms, -- * API of query with ordering orderBy, asc, desc, -- * Result extractOrderingTerms ) where import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) import Control.Arrow (second) import Data.DList (DList, toList) import Database.Relational.Query.Component (Order(Asc, Desc), OrderColumn, OrderingTerm, OrderingTerms) 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(..)) -- | Type to accumulate ordering context. -- Type 'c' is ordering term projection context type. newtype Orderings c m a = Orderings (WriterT (DList OrderingTerm) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Orderings'. orderings :: Monad m => m a -> Orderings c m a orderings = lift -- | 'MonadRestrict' with ordering. instance MonadRestrict rc m => MonadRestrict rc (Orderings c m) where restrict = orderings . restrict -- | 'MonadQualify' with ordering. instance MonadQualify q m => MonadQualify q (Orderings c m) where liftQualify = orderings . liftQualify -- | 'MonadQuery' with ordering. instance MonadQuery m => MonadQuery (Orderings c m) where setDuplication = orderings . setDuplication restrictJoin = orderings . restrictJoin query' = orderings . query' queryMaybe' = orderings . queryMaybe' -- | 'MonadAggregate' with ordering. instance MonadAggregate m => MonadAggregate (Orderings c m) where groupBy = orderings . groupBy groupBy' = orderings . groupBy' -- | 'MonadPartition' with ordering. instance MonadPartition c m => MonadPartition c (Orderings c m) where partitionBy = orderings . partitionBy -- | Ordering term projection type interface. class ProjectableOrdering p where orderTerms :: p t -> [OrderColumn] -- | 'Projection' is ordering term. instance ProjectableOrdering (Projection c) where orderTerms = Projection.columns -- | Add ordering terms. updateOrderBys :: (Monad m, ProjectableOrdering (Projection c)) => Order -- ^ Order direction -> Projection c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering updateOrderBys order p = Orderings . mapM_ tell $ terms where terms = curry pure order `map` orderTerms p -- | Add ordering terms. orderBy :: (Monad m, ProjectableOrdering (Projection c)) => Projection c t -- ^ Ordering terms to add -> Order -- ^ Order direction -> Orderings c m () -- ^ Result context with ordering orderBy = flip updateOrderBys -- | Add ascendant ordering term. asc :: (Monad m, ProjectableOrdering (Projection c)) => Projection c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering asc = updateOrderBys Asc -- | Add descendant ordering term. desc :: (Monad m, ProjectableOrdering (Projection c)) => Projection c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering desc = updateOrderBys Desc -- | Run 'Orderings' to get 'OrderingTerms' extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, OrderingTerms) extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Assigning.hs0000644000000000000000000000553313000574776025461 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Assigning -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift -- from context into context with assigning. module Database.Relational.Query.Monad.Trans.Assigning ( -- * Transformer into context with assignments Assignings, assignings, -- * API of context with assignments assignTo, (<-#), AssignTarget, -- * Result SQL set clause 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, (<$>)) import Control.Arrow (second) import Data.Monoid (mconcat) import Data.DList (DList, toList) import Database.Relational.Query.Component (Assignment, Assignments) 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(..)) -- | Type to accumulate assigning context. -- Type 'r' is table record type. newtype Assignings r m a = Assignings (WriterT (Table r -> DList Assignment) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Assignings' assignings :: Monad m => m a -> Assignings r m a assignings = lift -- | 'MonadRestrict' with assigning. instance MonadRestrict c m => MonadRestrict c (Assignings r m) where restrict = assignings . restrict -- | 'MonadQualify' with assigning. instance MonadQualify q m => MonadQualify q (Assignings r m) where liftQualify = assignings . liftQualify -- | Target of assignment. type AssignTarget r v = Pi r v targetProjection :: AssignTarget r v -> Table r -> Projection Flat v targetProjection pi' tbl = Projection.pi (Projection.unsafeFromTable tbl) pi' -- | Add an assignment. assignTo :: Monad m => Projection Flat v -> AssignTarget r v -> Assignings r m () assignTo vp target = Assignings . tell $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where leftsR = Projection.columns . targetProjection target rights = Projection.columns vp -- | Add and assginment. (<-#) :: Monad m => AssignTarget r v -> Projection Flat v -> Assignings r m () (<-#) = flip assignTo infix 4 <-# -- | Run 'Assignings' to get 'Assignments' extractAssignments :: (Monad m, Functor m) => Assignings r m a -> m (a, Table r -> Assignments) extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Restricting.hs0000644000000000000000000000501613000574776026030 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Restricting -- Copyright : 2014-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift to basic 'MonadQuery'. module Database.Relational.Query.Monad.Trans.Restricting ( -- * Transformer into restricted context Restrictings, restrictings, -- * Result extractRestrict ) where import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) import Control.Arrow (second) import Data.DList (DList, toList) import Database.Relational.Query.Sub (QueryRestriction, Projection) import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) -- | Type to accumulate query restrictions. -- Type 'c' is context tag of restriction building like -- Flat (where) or Aggregated (having). newtype Restrictings c m a = Restrictings (WriterT (DList (Projection c (Maybe Bool))) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Restrictings' restrictings :: Monad m => m a -> Restrictings c m a restrictings = lift -- | Add whole query restriction. updateRestriction :: Monad m => Projection c (Maybe Bool) -> Restrictings c m () updateRestriction = Restrictings . tell . pure -- | 'MonadRestrict' instance. instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where restrict = updateRestriction -- | Restricted 'MonadQualify' instance. instance MonadQualify q m => MonadQualify q (Restrictings c m) where liftQualify = restrictings . liftQualify -- | Restricted 'MonadQuery' instance. instance MonadQuery q => MonadQuery (Restrictings c q) where setDuplication = restrictings . setDuplication restrictJoin = restrictings . restrictJoin query' = restrictings . query' queryMaybe' = restrictings . queryMaybe' -- | Resticted 'MonadAggregate' instance. instance MonadAggregate m => MonadAggregate (Restrictings c m) where groupBy = restrictings . groupBy groupBy' = restrictings . groupBy' -- | Run 'Restrictings' to get 'QueryRestriction' extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, QueryRestriction c) extractRestrict (Restrictings rc) = second toList <$> runWriterT rc relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Config.hs0000644000000000000000000000235413000574776024742 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Config -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which requires query generate configuration. module Database.Relational.Query.Monad.Trans.Config ( -- * Transformer into query with configuration QueryConfig, queryConfig, runQueryConfig, askQueryConfig ) where import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Control.Applicative (Applicative) import Database.Relational.Query.Component (Config) -- | 'ReaderT' type to require query generate configuration. newtype QueryConfig m a = QueryConfig (ReaderT Config m a) deriving (Monad, Functor, Applicative) -- | Run 'QueryConfig' to expand with configuration runQueryConfig :: QueryConfig m a -> Config -> m a runQueryConfig (QueryConfig r) = runReaderT r -- | Lift to 'QueryConfig'. queryConfig :: Monad m => m a -> QueryConfig m a queryConfig = QueryConfig . lift -- | Read configuration. askQueryConfig :: Monad m => QueryConfig m Config askQueryConfig = QueryConfig ask relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Qualify.hs0000644000000000000000000000321313000574776025142 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Qualify -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which qualify uniquely SQL table forms. module Database.Relational.Query.Monad.Trans.Qualify ( -- * Qualify monad Qualify, qualify, evalQualifyPrime, qualifyQuery ) where import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT, runStateT, get, modify) import Control.Applicative (Applicative) import Control.Monad (liftM) import Database.Relational.Query.Sub (Qualified) import qualified Database.Relational.Query.Sub as SubQuery type AliasId = Int -- | Monad type to qualify SQL table forms. newtype Qualify m a = Qualify (StateT AliasId m a) deriving (Monad, Functor, Applicative) -- | Run qualify monad with initial state to get only result. evalQualifyPrime :: Monad m => Qualify m a -> m a evalQualifyPrime (Qualify s) = fst `liftM` runStateT s 0 {- primary alias id -} -- | Generated new qualifier on internal state. newAlias :: Monad m => Qualify m AliasId newAlias = Qualify $ do ai <- get modify (+ 1) return ai -- | Lift to 'Qualify' qualify :: Monad m => m a -> Qualify m a qualify = Qualify . lift -- | Get qualifyed table form query. qualifyQuery :: Monad m => query -- ^ Query to qualify -> Qualify m (Qualified query) -- ^ Result with updated state qualifyQuery query = do n <- newAlias return . SubQuery.qualify query $ SubQuery.Qualifier n relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/Join.hs0000644000000000000000000001020713000574776024430 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Join -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift to basic 'MonadQuery'. module Database.Relational.Query.Monad.Trans.Join ( -- * Transformer into join query QueryJoin, join', -- * Result extractProduct, -- * Unsafe API unsafeSubQueryWithAttr, ) where import Prelude hiding (product) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Monad.Trans.State (modify, StateT, runStateT) import Control.Applicative (Applicative, (<$>)) import Control.Arrow (second, (***)) import Data.Maybe (fromMaybe) import Data.Monoid (Last (Last, getLast)) 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 (..)) -- | 'StateT' type to accumulate join product context. newtype QueryJoin m a = QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a) deriving (Monad, Functor, Applicative) instance MonadTrans QueryJoin where lift = QueryJoin . lift . lift -- | Lift to 'QueryJoin' join' :: Monad m => m a -> QueryJoin m a join' = lift -- | Unsafely update join product context. updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m () updateContext = QueryJoin . modify -- | Add last join product restriction. updateJoinRestriction :: Monad m => Projection Flat (Maybe Bool) -> QueryJoin m () updateJoinRestriction e = updateContext (updateProduct d) where d Nothing = error "on: Product is empty! Restrict target product is not found!" d (Just pt) = restrictProduct pt e instance MonadQualify q m => MonadQualify q (QueryJoin m) where liftQualify = join' . liftQualify -- | Joinable query instance. instance MonadQuery (QueryJoin ConfigureQuery) where setDuplication = QueryJoin . lift . tell . Last . Just restrictJoin = updateJoinRestriction query' = queryWithAttr Just' queryMaybe' pr = do (ph, pj) <- queryWithAttr Maybe pr return (ph, Projection.just pj) -- | Unsafely join sub-query with this query. unsafeSubQueryWithAttr :: Monad q => NodeAttr -- ^ Attribute maybe or just -> Qualified SubQuery -- ^ 'SubQuery' to join -> QueryJoin q (Projection c r) -- ^ Result joined context and 'SubQuery' result projection. unsafeSubQueryWithAttr attr qsub = do updateContext (updateProduct (`growProduct` (attr, qsub))) return $ Projection.unsafeFromQualifiedSubQuery qsub -- | Basic monadic join operation using 'MonadQuery'. queryWithAttr :: NodeAttr -> Relation p r -> QueryJoin ConfigureQuery (PlaceHolders p, Projection c r) queryWithAttr attr = unsafeAddPlaceHolders . run where run rel = do q <- liftQualify $ do sq <- untypeRelation rel qualifyQuery sq unsafeSubQueryWithAttr attr q -- | Run 'QueryJoin' to get 'JoinProduct' extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication) extractProduct (QueryJoin s) = (second joinProduct *** (fromMaybe All . getLast)) <$> runWriterT (runStateT s primeJoinContext) relational-query-0.8.3.2/src/Database/Relational/Query/Monad/Trans/JoinState.hs0000644000000000000000000000232313000574776025431 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Monad.Trans.JoinState -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides state definition for -- "Database.Relational.Query.Monad.Trans.Join". module Database.Relational.Query.Monad.Trans.JoinState ( -- * Join context JoinContext, primeJoinContext, updateProduct, joinProduct ) where import Prelude hiding (product) import Data.DList (toList) import qualified Database.Relational.Query.Sub as Product import Database.Relational.Query.Sub (ProductBuilder, JoinProduct) -- | JoinContext type for QueryJoin. newtype JoinContext = JoinContext { product :: Maybe ProductBuilder } -- | Initial 'JoinContext'. primeJoinContext :: JoinContext primeJoinContext = JoinContext Nothing -- | Update product of 'JoinContext'. updateProduct :: (Maybe ProductBuilder -> ProductBuilder) -> JoinContext -> JoinContext updateProduct uf ctx = ctx { product = Just . uf . product $ ctx } -- | Finalize context to extract accumulated query product. joinProduct :: JoinContext -> JoinProduct joinProduct = fmap (fmap toList . Product.nodeTree) . product relational-query-0.8.3.2/src/Database/Relational/Query/Pi/0000755000000000000000000000000013000574776021420 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/Query/Pi/Unsafe.hs0000644000000000000000000001120113000574776023170 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Pi.Unsafe -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed projection path objects. -- Contains internal structure and unsafe interfaces. module Database.Relational.Query.Pi.Unsafe ( -- * Projection path Pi, pfmap, pap, width, (<.>), (), (), pi, definePi, defineDirectPi', defineDirectPi, unsafeExpandIndexes ) where import Prelude hiding (pi) import Data.Array (listArray, (!)) import Database.Record.Persistable (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>), PersistableWidth (persistableWidth), maybeWidth) import Database.Relational.Query.Pure (ProductConstructor (..)) -- | Projection path primary structure type. data Pi' r0 r1 = Leftest Int | Map [Int] unsafePiAppend' :: Pi' a b' -> Pi' b c' -> Pi' a c unsafePiAppend' = d where d (Leftest i) (Leftest j) = Leftest $ i + j d (Leftest i) (Map js) = Map $ map (i +) js d (Map is) (Leftest j) = Map $ drop j is d (Map is) (Map js) = Map [ is' ! j | j <- js ] where is' = listArray (0, length is) is -- | Projection path from type 'r0' into type 'r1'. -- This type also indicate key object which type is 'r1' for record type 'r0'. data Pi r0 r1 = Pi (Pi' r0 r1) (PersistableRecordWidth r1) unsafePiAppend :: (PersistableRecordWidth c' -> PersistableRecordWidth c) -> Pi a b' -> Pi b c' -> Pi a c unsafePiAppend f (Pi p0 _) (Pi p1 w) = Pi (p0 `unsafePiAppend'` p1) (f w) -- | Unsafely untype key to expand indexes. unsafeExpandIndexes :: Pi a b -> [Int] unsafeExpandIndexes = d where d (Pi (Map is) _) = is d (Pi (Leftest i) w) = [ i .. i + w' - 1 ] where w' = runPersistableRecordWidth w -- | Unsafely cast width proof object of record. Result record must be same width. unsafeCastRecordWidth :: PersistableRecordWidth a -> PersistableRecordWidth a' unsafeCastRecordWidth = unsafePersistableRecordWidth . runPersistableRecordWidth unsafeCast :: Pi a b' -> Pi a b unsafeCast = c where d (Leftest i) = Leftest i d (Map m) = Map m c (Pi p w) = Pi (d p) (unsafeCastRecordWidth w) -- | Projectable fmap of 'Pi' type. pfmap :: ProductConstructor (a -> b) => (a -> b) -> Pi r a -> Pi r b _ `pfmap` p = unsafeCast p -- | Projectable ap of 'Pi' type. pap :: Pi r (a -> b) -> Pi r a -> Pi r b pap b@(Pi _ wb) c@(Pi _ wc) = Pi (Map $ unsafeExpandIndexes b ++ unsafeExpandIndexes c) (unsafeCastRecordWidth $ wb <&> wc) -- | Get record width proof object. width' :: Pi r ct -> PersistableRecordWidth ct width' (Pi _ w) = w -- | Get record width. width :: Pi r a -> Int width = runPersistableRecordWidth . width' -- | Compose projection path. (<.>) :: Pi a b -> Pi b c -> Pi a c (<.>) = unsafePiAppend id -- | Compose projection path. 'Maybe' phantom functor is 'map'-ed. () :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c) () = unsafePiAppend maybeWidth -- | Compose projection path. 'Maybe' phantom functors are 'join'-ed like '>=>'. () :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c) () = unsafePiAppend id infixl 8 <.>, , -- | Unsafely project untyped value list. pi :: [a] -> Pi r0 r1 -> [a] pi cs (Pi p' w) = d p' where d (Leftest i) = take (runPersistableRecordWidth w) . drop i $ cs d (Map is) = [cs' ! i | i <- is] cs' = listArray (0, length cs) cs -- | Unsafely define projection path from type 'r0' into type 'r1'. definePi' :: PersistableRecordWidth r1 -> Int -- ^ Index of flat SQL value list -> Pi r0 r1 -- ^ Result projection path definePi' pw i = Pi (Leftest i) pw -- | Unsafely define projection path from type 'r0' into type 'r1'. -- Use inferred 'PersistableRecordWidth'. definePi :: PersistableWidth r1 => Int -- ^ Index of flat SQL value list -> Pi r0 r1 -- ^ Result projection path definePi = definePi' persistableWidth -- | Unsafely define projection path from type 'r0' into type 'r1'. defineDirectPi' :: PersistableRecordWidth r1 -> [Int] -- ^ Indexes of flat SQL value list -> Pi r0 r1 -- ^ Result projection path defineDirectPi' pw is = Pi (Map is) pw -- | Unsafely define projection path from type 'r0' into type 'r1'. -- Use inferred 'PersistableRecordWidth'. defineDirectPi :: PersistableWidth r1 => [Int] -- ^ Indexes of flat SQL value list -> Pi r0 r1 -- ^ Result projection path defineDirectPi = defineDirectPi' persistableWidth relational-query-0.8.3.2/src/Database/Relational/Query/Internal/0000755000000000000000000000000013000574776022624 5ustar0000000000000000relational-query-0.8.3.2/src/Database/Relational/Query/Internal/Product.hs0000644000000000000000000000425113000574776024602 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.Product -- Copyright : 2013-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines product structure to compose SQL join. module Database.Relational.Query.Internal.Product ( -- * Interfaces to manipulate ProductTree type growProduct, restrictProduct, ) where import Prelude hiding (and, product) import Control.Applicative (pure) import Data.Monoid ((<>), mempty) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Internal.Sub (NodeAttr (..), ProductTree (..), Node (..), Projection, Qualified, SubQuery, ProductTreeBuilder, ProductBuilder) -- | Push new tree into product right term. growRight :: Maybe ProductBuilder -- ^ Current tree -> (NodeAttr, ProductTreeBuilder) -- ^ New tree to push into right -> ProductBuilder -- ^ Result node growRight = d where d Nothing (naR, q) = Node naR q d (Just l) (naR, q) = Node Just' $ Join l (Node naR q) mempty -- | Push new leaf node into product right term. growProduct :: Maybe ProductBuilder -- ^ Current tree -> (NodeAttr, Qualified SubQuery) -- ^ New leaf to push into right -> ProductBuilder -- ^ Result node growProduct = match where match t (na, q) = growRight t (na, Leaf q) -- | Add restriction into top product of product tree. restrictProduct' :: ProductTreeBuilder -- ^ Product to restrict -> Projection Flat (Maybe Bool) -- ^ Restriction to add -> ProductTreeBuilder -- ^ Result product restrictProduct' = d where d (Join lp rp rs) rs' = Join lp rp (rs <> pure rs') d leaf'@(Leaf _) _ = leaf' -- or error on compile -- | Add restriction into top product of product tree node. restrictProduct :: ProductBuilder -- ^ Target node which has product to restrict -> Projection Flat (Maybe Bool) -- ^ Restriction to add -> ProductBuilder -- ^ Result node restrictProduct (Node a t) e = Node a (restrictProduct' t e) relational-query-0.8.3.2/src/Database/Relational/Query/Internal/SQL.hs0000644000000000000000000000244013000574776023617 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.SQL -- Copyright : 2014 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides SQL string wrap interfaces. module Database.Relational.Query.Internal.SQL ( StringSQL, stringSQL, showStringSQL, rowStringSQL, rowPlaceHolderStringSQL, rowConsStringSQL, listStringSQL, ) where import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren) -- | String wrap type for SQL strings. type StringSQL = Keyword -- | 'StringSQL' from 'String'. stringSQL :: String -> StringSQL stringSQL = word -- | 'StringSQL' to 'String'. showStringSQL :: StringSQL -> String showStringSQL = wordShow -- | Row String of SQL values. rowStringSQL :: [StringSQL] -> StringSQL rowStringSQL = d where d [] = error "Projection: no columns." d [c] = c d cs = paren $ fold (|*|) cs -- | Place holder row String of SQL. rowPlaceHolderStringSQL :: Int -> StringSQL rowPlaceHolderStringSQL = rowStringSQL . (`replicate` stringSQL "?") -- | List String of SQL. rowConsStringSQL :: [StringSQL] -> StringSQL rowConsStringSQL = paren . fold (|*|) -- | List String of SQL. listStringSQL :: [StringSQL] -> StringSQL listStringSQL = paren . fold (|*|) relational-query-0.8.3.2/src/Database/Relational/Query/Internal/Sub.hs0000644000000000000000000000701513000574776023714 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} -- | -- Module : Database.Relational.Query.Internal.Sub -- Copyright : 2015-2016 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines sub-query structure used in query products. module Database.Relational.Query.Internal.Sub ( SubQuery (..), UntypedProjection, ProjectionUnit (..) , SetOp (..), BinOp (..), Qualifier (..), Qualified (..) -- * Product tree type , NodeAttr (..), ProductTree (..), Node (..) , JoinProduct, QueryProductTree , ProductTreeBuilder, ProductBuilder , Projection, untypeProjection, typedProjection -- * Query restriction , QueryRestriction ) where import Prelude hiding (and, product) import Data.Array (Array) import Data.DList (DList) 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 -- | Set operators data SetOp = Union | Except | Intersect deriving Show -- | Set binary operators newtype BinOp = BinOp (SetOp, Duplication) deriving Show -- | Sub-query type data SubQuery = Table Table.Untyped | Flat Config UntypedProjection Duplication JoinProduct (QueryRestriction Flat) OrderingTerms | Aggregated Config UntypedProjection Duplication JoinProduct (QueryRestriction Flat) [AggregateElem] (QueryRestriction Aggregated) OrderingTerms | Bin BinOp SubQuery SubQuery deriving Show -- | Qualifier type. newtype Qualifier = Qualifier Int deriving Show -- | Qualified query. data Qualified a = Qualified a Qualifier deriving Show -- | 'Functor' instance of 'Qualified' instance Functor Qualified where fmap f (Qualified a i) = Qualified (f a) i -- | Projection structure unit data ProjectionUnit = Columns (Array Int ColumnSQL) | Normalized (Qualified Int) | Scalar SubQuery deriving Show -- | Untyped projection. Forgot record type. type UntypedProjection = [ProjectionUnit] -- | node attribute for product. data NodeAttr = Just' | Maybe deriving Show type QS = Qualified SubQuery type QueryRestrictionBuilder = DList (Projection Flat (Maybe Bool)) -- | Product tree type. Product tree is constructed by left node and right node. data ProductTree rs = Leaf QS | Join !(Node rs) !(Node rs) !rs deriving (Show, Functor) -- | Product node. node attribute and product tree. data Node rs = Node !NodeAttr !(ProductTree rs) deriving (Show, Functor) -- | Product tree with join restriction. type QueryProductTree = ProductTree (QueryRestriction Flat) -- | Product tree with join restriction builder. type ProductTreeBuilder = ProductTree QueryRestrictionBuilder -- | Product noe with join restriction builder. type ProductBuilder = Node QueryRestrictionBuilder -- | Type for join product of query. type JoinProduct = Maybe QueryProductTree -- | Phantom typed projection. Projected into Haskell record type 't'. newtype Projection c t = Projection { untypeProjection :: UntypedProjection {- ^ Discard projection value type -} } deriving Show -- | Unsafely type projection value. typedProjection :: UntypedProjection -> Projection c t typedProjection = Projection -- | Type for restriction of query. type QueryRestriction c = [Projection c (Maybe Bool)] relational-query-0.8.3.2/test/0000755000000000000000000000000013000574776014335 5ustar0000000000000000relational-query-0.8.3.2/test/sqlsEq.hs0000644000000000000000000004512013000574776016143 0ustar0000000000000000 import Test.QuickCheck.Simple (Test, defaultMain) import Control.Applicative ((<$>), (<*>)) import Lex (eqProp) import Model import Data.Int (Int32, Int64) import Database.Relational.Query tables :: [Test] tables = [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" , eqProp "setB" setB "SELECT int_b0, may_str_b1, str_b2 FROM TEST.set_b" , eqProp "setC" setC "SELECT int_c0, str_c1, int_c2, may_str_c3 FROM TEST.set_c" ] _p_tables :: IO () _p_tables = mapM_ print [show setA, show setB, show setC] -- Monadic Operators tests queryX :: Relation () SetA queryX = relation $ do a <- query setA return a queryMaybeX :: Relation () (Maybe SetA) queryMaybeX = relation $ do a <- queryMaybe setA return a onX :: Relation () (Maybe SetA, SetB) onX = relation $ do a <- queryMaybe setA b <- query setB on $ a ?! intA0' .=. just (b ! intB0') return $ (,) |$| a |*| b wheresX :: Relation () (SetA, SetB) wheresX = relation $ do a <- query setA b <- query setB wheres $ b ! intB0' .>=. value 3 return $ (,) |$| a |*| b groupByX :: Relation () (Int32, Integer) groupByX = aggregateRelation $ do a <- query setA ga0 <- groupBy $ a ! intA0' return $ (,) |$| ga0 |*| count (a ! intA0') havingX :: Relation () Int havingX = aggregateRelation $ do a <- query setA let c = count (a ! intA0') having $ c .>. value 1 return c distinctX :: Relation () Int32 distinctX = relation $ do distinct a <- query setA return $ a ! intA0' all'X :: Relation () Int32 all'X = relation $ do all' a <- query setA return $ a ! intA0' assignX :: Update () assignX = derivedUpdate $ \_proj -> do intA0' <-# value (0 :: Int32) return unitPlaceHolder registerX :: Insert () registerX = derivedInsertValue $ do intA0' <-# value 1 strA1' <-# value "Hello" strA2' <-# value "World" return unitPlaceHolder monadic :: [Test] monadic = [ eqProp "query" queryX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2 FROM TEST.set_a T0" , eqProp "queryMaybe" queryMaybeX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2 FROM TEST.set_a T0" , eqProp "on" onX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" , eqProp "wheres" wheresX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0) \ \ WHERE (T1.int_b0 >= 3)" , eqProp "groupBy" groupByX "SELECT ALL T0.int_a0 AS f0, COUNT(T0.int_a0) AS f1 \ \ FROM TEST.set_a T0 GROUP BY T0.int_a0" , eqProp "having" havingX "SELECT ALL COUNT(T0.int_a0) AS f0 FROM TEST.set_a T0 HAVING (COUNT(T0.int_a0) > 1)" , eqProp "distinct" distinctX "SELECT DISTINCT T0.int_a0 AS f0 FROM TEST.set_a T0" , eqProp "all'" all'X "SELECT ALL T0.int_a0 AS f0 FROM TEST.set_a T0" , eqProp "update" assignX "UPDATE TEST.set_a SET int_a0 = 0" , eqProp "insert" registerX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (1, 'Hello', 'World')" ] _p_monadic :: IO () _p_monadic = mapM_ putStrLn [ show queryX, show queryMaybeX, show onX, show wheresX , show groupByX, show havingX, show distinctX, show all'X , show assignX ] -- Direct Join Operators cross :: Relation () (SetA, SetB) cross = setA `inner` setB `on'` [] innerX :: Relation () (SetA, SetB) innerX = setA `inner` setB `on'` [ \a b -> a ! intA0' .=. b ! intB0' ] leftX :: Relation () (SetA, Maybe SetB) leftX = setA `left` setB `on'` [ \a b -> just (a ! strA1') .=. b ?!? mayStrB1' ] rightX :: Relation () (Maybe SetA, SetB) rightX = setA `right` setB `on'` [ \a b -> a ?! intA0' .=. just (b ! intB0') ] fullX :: Relation () (Maybe SetA, Maybe SetB) fullX = setA `full` setB `on'` [ \a b -> a ?! intA0' .=. b ?! intB0' ] directJoins :: [Test] directJoins = [ eqProp "cross" cross "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0)" , eqProp "inner" innerX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" , eqProp "left" leftX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a1 = T1.may_str_b1)" , eqProp "right" rightX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" , eqProp "full" fullX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 FULL JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" ] _p_directJoins :: IO () _p_directJoins = mapM_ print [show cross, show innerX, show leftX, show rightX, show fullX] j3left :: Relation () Abc j3left = relation $ do a <- query setA b <- queryMaybe setB on $ just (a ! strA2') .=. b ?! strB2' c <- queryMaybe setC on $ b ?! intB0' .=. c ?! intC0' return $ Abc |$| a |*| b |*| c j3right :: Relation () Abc j3right = relation $ do a <- query setA bc <- query $ setB `full` setC `on'` [ \b c -> b ?! intB0' .=. c ?! intC0' ] let b = bc ! fst' c = bc ! snd' on $ just (a ! strA2') .=. b ?! strB2' return $ Abc |$| a |*| b |*| c join3s :: [Test] join3s = [ eqProp "join-3 left" j3left "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5, \ \ T2.int_c0 AS f6, T2.str_c1 AS f7, T2.int_c2 AS f8, T2.may_str_c3 AS f9 \ \ FROM (TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2)) \ \ LEFT JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)" , eqProp "join-3 right" j3right "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T3.f0 AS f3, T3.f1 AS f4, T3.f2 AS f5, T3.f3 AS f6, T3.f4 AS f7, T3.f5 AS f8, T3.f6 AS f9 \ \ FROM TEST.set_a T0 \ \ INNER JOIN (SELECT ALL T1.int_b0 AS f0, T1.may_str_b1 AS f1, T1.str_b2 AS f2, \ \ T2.int_c0 AS f3, T2.str_c1 AS f4, T2.int_c2 AS f5, T2.may_str_c3 AS f6 \ \ FROM TEST.set_b T1 FULL JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)) T3 \ \ ON (T0.str_a2 = T3.f2)" ] _p_j3s :: IO () _p_j3s = mapM_ print [show j3left, show j3right] -- Projection Operators bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r bin53 op = relation $ do return $ value 5 `op` value 3 strIn :: Relation () (Maybe Bool) strIn = relation $ return $ value "foo" `in'` values ["foo", "bar"] boolTF :: (Projection Flat (Maybe Bool) -> Projection Flat (Maybe Bool) -> Projection Flat r) -> Relation () r boolTF op = relation $ do return $ valueTrue `op` valueFalse strConcat :: Relation () String strConcat = relation $ do return $ value "Hello, " .||. value "World!" strLike :: Relation () (Maybe Bool) strLike = relation $ do return $ value "Hoge" `like` "H%" _p_bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO () _p_bin53 = print . bin53 bin :: [Test] bin = [ eqProp "equal" (bin53 (.=.)) "SELECT ALL (5 = 3) AS f0" , eqProp "lt" (bin53 (.<.)) "SELECT ALL (5 < 3) AS f0" , eqProp "le" (bin53 (.<=.)) "SELECT ALL (5 <= 3) AS f0" , eqProp "gt" (bin53 (.>.)) "SELECT ALL (5 > 3) AS f0" , eqProp "ge" (bin53 (.>=.)) "SELECT ALL (5 >= 3) AS f0" , eqProp "ne" (bin53 (.<>.)) "SELECT ALL (5 <> 3) AS f0" , eqProp "and" (boolTF and') "SELECT ALL ((0=0) AND (0=1)) AS f0" , eqProp "or" (boolTF or') "SELECT ALL ((0=0) OR (0=1)) AS f0" , eqProp "in" strIn "SELECT ALL ('foo' IN ('foo', 'bar')) AS f0" , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0" , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0" , eqProp "plus" (bin53 (.+.)) "SELECT ALL (5 + 3) AS f0" , eqProp "minus" (bin53 (.-.)) "SELECT ALL (5 - 3) AS f0" , eqProp "mult" (bin53 (.*.)) "SELECT ALL (5 * 3) AS f0" , eqProp "div" (bin53 (./.)) "SELECT ALL (5 / 3) AS f0" ] nothingX :: Relation () (SetA, Maybe SetB) nothingX = relation $ do a <- query setA b <- queryMaybe setB wheres $ isNothing b `or'` a ! intA0' .=. value 1 return $ a >< b justX :: Relation () (SetA, Maybe SetB) justX = relation $ do a <- query setA b <- queryMaybe setB wheres $ isJust b `or'` a ! intA0' .=. value 1 return $ a >< b maybeX :: Relation () (Int32, SetB) maybeX = relation $ do a <- queryMaybe setA b <- query setB wheres $ a ?! strA2' .=. b ! mayStrB1' return $ fromMaybe (value 1) (a ?! intA0') >< b notX :: Relation () (Maybe Bool) notX = relation $ return $ not' valueFalse existsX :: Relation () (Maybe Bool) existsX = relation $ return . exists =<< queryList setA uni :: [Test] uni = [ eqProp "isNothing" nothingX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) \ \ WHERE ((T1.int_b0 IS NULL) OR (T0.int_a0 = 1))" , eqProp "isJust" justX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) \ \ WHERE ((NOT (T1.int_b0 IS NULL)) OR (T0.int_a0 = 1))" , eqProp "fromMaybe" maybeX "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, \ \ T1.int_b0 AS f1, T1.may_str_b1 AS f2, T1.str_b2 AS f3 \ \ FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)" , eqProp "not" notX "SELECT ALL (NOT (0=1)) AS f0" , eqProp "exists" existsX "SELECT ALL (EXISTS (SELECT int_a0, str_a1, str_a2 FROM TEST.set_a)) AS f0" ] _p_uni :: IO () _p_uni = mapM_ print [show nothingX, show justX, show maybeX, show notX, show existsX] groupX :: Relation () (String, Int64) groupX = aggregateRelation $ do c <- query setC gc1 <- groupBy $ c ! strC1' return $ gc1 >< count (c ! intC0') cubeX :: Relation () ((Maybe String, Maybe (Int64, Maybe String)), Maybe Int32) cubeX = aggregateRelation $ do c <- query setC gCube <- groupBy' . cube $ do (><) <$> bkey (c ! strC1') <*> bkey (c ! intC2' >< c ! mayStrC3') return $ gCube >< sum' (c ! intC0') groupingSetsX :: Relation () (((Maybe String, Maybe (Maybe String)), Maybe Int64), Maybe Int64) groupingSetsX = aggregateRelation $ do c <- query setC gs <- groupBy' . groupingSets $ do s1 <- set $ do gRollup <- key' . rollup $ do (><) <$> bkey (c ! strC1') <*> bkey (c ! mayStrC3') gc2 <- key $ c ! intC2' return $ gRollup >< gc2 s2 <- set . key $ c ! intC2' return $ s1 >< s2 return gs groups :: [Test] groups = [ eqProp "group" groupX "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \ \ FROM TEST.set_c T0 GROUP BY T0.str_c1" , eqProp "cube" cubeX "SELECT ALL T0.str_c1 AS f0, T0.int_c2 AS f1, T0.may_str_c3 AS f2, SUM(T0.int_c0) AS f3 \ \ FROM TEST.set_c T0 GROUP BY CUBE ((T0.str_c1), (T0.int_c2, T0.may_str_c3))" , eqProp "groupingSets" groupingSetsX "SELECT ALL T0.str_c1 AS f0, T0.may_str_c3 AS f1, T0.int_c2 AS f2, T0.int_c2 AS f3 \ \ FROM TEST.set_c T0 GROUP BY \ \ GROUPING SETS ((ROLLUP ((T0.str_c1), (T0.may_str_c3)), T0.int_c2), (T0.int_c2))" ] _p_groups :: IO () _p_groups = mapM_ print [show groupX, show cubeX, show groupingSetsX] ordFlatX :: Relation () (SetA, Maybe SetB) ordFlatX = relation $ do a <- query setA b <- queryMaybe setB on $ just (a ! strA2') .=. b ?! strB2' orderBy (a ! strA1') Asc orderBy (b ?! mayStrB1') Desc return $ (,) |$| a |*| b ordAggX :: Relation () (String, Int64) ordAggX = aggregateRelation $ do c <- query setC gc1 <- groupBy $ c ! strC1' orderBy (sum' $ c ! intC0') Asc return $ gc1 >< count (c ! intC0') _p_orders :: IO () _p_orders = mapM_ print [show ordFlatX, show ordAggX] orders :: [Test] orders = [ eqProp "order-by - flat" ordFlatX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2) \ \ ORDER BY T0.str_a1 ASC, T1.may_str_b1 DESC" , eqProp "order-by - aggregated" ordAggX "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \ \ FROM TEST.set_c T0 GROUP BY T0.str_c1 ORDER BY SUM(T0.int_c0) ASC" ] partitionX :: Relation () (String, Int64) partitionX = relation $ do c <- query setC return $ (c ! strC1') >< rank `over` do partitionBy $ c ! strC1' orderBy (c ! intC2') Asc partitionY :: Relation () (String, (Int64, Maybe Int32)) partitionY = relation $ do c <- query setC return $ (c ! strC1') >< (rank >< sum' (c ! intC0'))`over` do partitionBy $ c ! strC1' orderBy (c ! intC2') Asc partitions :: [Test] partitions = [ eqProp "partition 0" partitionX "SELECT ALL T0.str_c1 AS f0, \ \ RANK() OVER (PARTITION BY T0.str_c1 ORDER BY T0.int_c2 ASC) AS f1 \ \ FROM TEST.set_c T0" , eqProp "partition 1" partitionY "SELECT ALL T0.str_c1 AS f0, \ \ RANK() OVER (PARTITION BY T0.str_c1 ORDER BY T0.int_c2 ASC) AS f1, \ \ SUM(T0.int_c0) OVER (PARTITION BY T0.str_c1 ORDER BY T0.int_c2 ASC) AS f2 \ \ FROM TEST.set_c T0" ] _p_partitions :: IO () _p_partitions = mapM_ print [show partitionX, show partitionY] setAFromB :: Pi SetB SetA setAFromB = SetA |$| intB0' |*| strB2' |*| strB2' aFromB :: Relation () SetA aFromB = relation $ do x <- query setB return $ x ! setAFromB unionX :: Relation () SetA unionX = setA `union` aFromB unionAllX :: Relation () SetA unionAllX = setA `unionAll` aFromB exceptX :: Relation () SetA exceptX = setA `except` aFromB intersectX :: Relation () SetA intersectX = setA `intersect` aFromB exps :: [Test] exps = [ eqProp "union" unionX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a UNION \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" , eqProp "unionAll" unionAllX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a UNION ALL \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" , eqProp "except" exceptX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a EXCEPT \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" , eqProp "intersect" intersectX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a INTERSECT \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" ] insertX :: Insert SetA insertX = derivedInsert id' insertI :: Insert SetI insertI = derivedInsert id' insertQueryX :: InsertQuery () insertQueryX = derivedInsertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = derivedUpdate $ \proj -> do strA2' <-# value "X" wheres $ proj ! strA1' .=. value "A" return unitPlaceHolder deleteX :: Delete () deleteX = derivedDelete $ \proj -> do wheres $ proj ! strA1' .=. value "A" return unitPlaceHolder effs :: [Test] effs = [ eqProp "insert" insertX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)" , eqProp "insert1" insertI "INSERT INTO TEST.set_i (int_i0) VALUES (?)" , eqProp "insertQuery" insertQueryX "INSERT INTO TEST.set_b (int_b0, str_b2, str_b2) SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" , eqProp "updateKey" updateKeyX "UPDATE TEST.set_a SET str_a1 = ?, str_a2 = ? WHERE int_a0 = ?" , eqProp "update" updateX "UPDATE TEST.set_a SET str_a2 = 'X' WHERE (str_a1 = 'A')" , eqProp "delete" deleteX "DELETE FROM TEST.set_a WHERE (str_a1 = 'A')" ] updateExistsX :: Update () updateExistsX = derivedUpdate $ \proj -> do strA2' <-# value "X" wheres . exists =<< (queryList . relation $ do b <- query setB wheres $ b ! intB0' .=. proj ! intA0' return b) return unitPlaceHolder updateScalarX :: Update () updateScalarX = derivedUpdate $ \proj -> do strA2' <-# value "X" sb <- queryScalar . unsafeUnique . relation $ do b <- query setB wheres $ b ! intB0' .=. value 0 return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb return unitPlaceHolder deleteExistsX :: Delete () deleteExistsX = derivedDelete $ \proj -> do wheres . exists =<< (queryList . relation $ do b <- query setB wheres $ b ! intB0' .=. proj ! intA0' return b) return unitPlaceHolder deleteScalarX :: Delete () deleteScalarX = derivedDelete $ \proj -> do sb <- queryScalar . unsafeUnique . relation $ do b <- query setB wheres $ b ! intB0' .=. value 0 return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb return unitPlaceHolder correlated :: [Test] correlated = [ eqProp "update-exists" updateExistsX "UPDATE TEST.set_a SET str_a2 = 'X' \ \ WHERE (EXISTS (SELECT ALL T0.int_b0 AS f0, T0.may_str_b1 AS f1, T0.str_b2 AS f2 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = int_a0)))" , eqProp "update-scalar" updateScalarX "UPDATE TEST.set_a SET str_a2 = 'X' \ \ WHERE (int_a0 = (SELECT ALL T0.int_b0 AS f0 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = 0)))" , eqProp "delete-exists" deleteExistsX "DELETE FROM TEST.set_a \ \ WHERE (EXISTS (SELECT ALL T0.int_b0 AS f0, T0.may_str_b1 AS f1, T0.str_b2 AS f2 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = int_a0)))" , eqProp "delete-scalar" deleteScalarX "DELETE FROM TEST.set_a \ \ WHERE (int_a0 = (SELECT ALL T0.int_b0 AS f0 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = 0)))" ] tests :: [Test] tests = concat [ tables, monadic, directJoins, join3s, bin, uni , groups, orders, partitions, exps, effs, correlated] main :: IO () main = defaultMain tests relational-query-0.8.3.2/test/Model.hs0000644000000000000000000000240613000574776015733 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Model where import Data.Int (Int32, Int64) import Database.Relational.Query (defaultConfig) import Database.Relational.Query.TH (defineTable, makeRelationalRecordDefault, defineScalarDegree) $(defineTable defaultConfig "TEST" "set_a" [ ("int_a0" , [t| Int32 |]) , ("str_a1" , [t| String |]) , ("str_a2" , [t| String |]) ] [] [0] $ Just 0) $(defineTable defaultConfig "TEST" "set_b" [ ("int_b0" , [t| Int32 |]) , ("may_str_b1" , [t| Maybe String |]) , ("str_b2" , [t| String |]) ] [] [0] $ Just 0) $(defineTable defaultConfig "TEST" "set_c" [ ("int_c0" , [t| Int32 |]) , ("str_c1" , [t| String |]) , ("int_c2" , [t| Int64 |]) , ("may_str_c3" , [t| Maybe String |]) ] [] [0] $ Just 0) $(defineTable defaultConfig "TEST" "set_i" [ ("int_i0" , [t| Int32 |]) ] [] [0] $ Just 0) data ABC = ABC { xJustA :: SetA , xJustB :: SetB , xJustC :: SetC } $(makeRelationalRecordDefault ''ABC) data Abc = Abc { yJustA :: SetA , yMayB :: Maybe SetB , yMayC :: Maybe SetC } $(makeRelationalRecordDefault ''Abc) $(defineScalarDegree [t| Int32 |]) relational-query-0.8.3.2/test/sqlsEqArrow.hs0000644000000000000000000003054613000574776017164 0ustar0000000000000000{-# LANGUAGE Arrows #-} import Test.QuickCheck.Simple (Test, defaultMain) import Lex (eqProp) import Model import Data.Int (Int32, Int64) import Control.Arrow (returnA, arr, (<<<), (***)) import Database.Relational.Query.Arrow numBin :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r numBin op = relation $ proc () -> do returnA -< value 5 `op` value 3 strConcat :: Relation () String strConcat = relation $ proc () -> do returnA -< value "Hello, " .||. value "World!" strLike :: Relation () (Maybe Bool) strLike = relation $ proc () -> do returnA -< value "Hoge" `like` "H%" _p_numBin :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO () _p_numBin = print . numBin bin :: [Test] bin = [ eqProp "plus" (numBin (.+.)) "SELECT ALL (5 + 3) AS f0" , eqProp "minus" (numBin (.-.)) "SELECT ALL (5 - 3) AS f0" , eqProp "mult" (numBin (.*.)) "SELECT ALL (5 * 3) AS f0" , eqProp "div" (numBin (./.)) "SELECT ALL (5 / 3) AS f0" , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0" , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0" ] tables :: [Test] tables = [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" , eqProp "setB" setB "SELECT int_b0, may_str_b1, str_b2 FROM TEST.set_b" , eqProp "setC" setC "SELECT int_c0, str_c1, int_c2, may_str_c3 FROM TEST.set_c" ] _p_tables :: IO () _p_tables = mapM_ print [show setA, show setB, show setC] cross :: Relation () (SetA, SetB) cross = setA `inner` setB `on'` [] innerX :: Relation () (SetA, SetB) innerX = setA `inner` setB `on'` [ \a b -> a ! intA0' .=. b ! intB0' ] leftX :: Relation () (SetA, Maybe SetB) leftX = setA `left` setB `on'` [ \a b -> just (a ! strA1') .=. b ?!? mayStrB1' ] rightX :: Relation () (Maybe SetA, SetB) rightX = setA `right` setB `on'` [ \a b -> a ?! intA0' .=. just (b ! intB0') ] fullX :: Relation () (Maybe SetA, Maybe SetB) fullX = setA `full` setB `on'` [ \a b -> a ?! intA0' .=. b ?! intB0' ] directJoins :: [Test] directJoins = [ eqProp "cross" cross "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0)" , eqProp "inner" innerX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" , eqProp "left" leftX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a1 = T1.may_str_b1)" , eqProp "right" rightX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" , eqProp "full" fullX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 FULL JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" ] _p_directJoins :: IO () _p_directJoins = mapM_ print [show cross, show innerX, show leftX, show rightX, show fullX] j3left :: Relation () Abc j3left = relation $ proc () -> do a <- query setA -< () b <- queryMaybe setB -< () on -< just (a ! strA2') .=. b ?! strB2' c <- queryMaybe setC -< () on -< b ?! intB0' .=. c ?! intC0' returnA -< Abc |$| a |*| b |*| c j3right :: Relation () Abc j3right = relation $ proc () -> do a <- query setA -< () bc <- query $ setB `full` setC `on'` [ \b c -> b ?! intB0' .=. c ?! intC0' ] -< () let b = bc ! fst' c = bc ! snd' on -< just (a ! strA2') .=. b ?! strB2' returnA -< Abc |$| a |*| b |*| c join3s :: [Test] join3s = [ eqProp "join-3 left" j3left "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5, \ \ T2.int_c0 AS f6, T2.str_c1 AS f7, T2.int_c2 AS f8, T2.may_str_c3 AS f9 \ \ FROM (TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2)) \ \ LEFT JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)" , eqProp "join-3 right" j3right "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T3.f0 AS f3, T3.f1 AS f4, T3.f2 AS f5, T3.f3 AS f6, T3.f4 AS f7, T3.f5 AS f8, T3.f6 AS f9 \ \ FROM TEST.set_a T0 \ \ INNER JOIN (SELECT ALL T1.int_b0 AS f0, T1.may_str_b1 AS f1, T1.str_b2 AS f2, \ \ T2.int_c0 AS f3, T2.str_c1 AS f4, T2.int_c2 AS f5, T2.may_str_c3 AS f6 \ \ FROM TEST.set_b T1 FULL JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)) T3 \ \ ON (T0.str_a2 = T3.f2)" ] _p_j3s :: IO () _p_j3s = mapM_ print [show j3left, show j3right] justX :: Relation () (SetA, Maybe SetB) justX = relation $ proc () -> do a <- query setA -< () b <- queryMaybe setB -< () wheres -< isJust b `or'` a ! intA0' .=. value 1 returnA -< a >< b maybeX :: Relation () (Int32, SetB) maybeX = relation $ proc () -> do a <- queryMaybe setA -< () b <- query setB -< () wheres -< a ?! strA2' .=. b ! mayStrB1' returnA -< fromMaybe (value 1) (a ?! intA0') >< b maybes :: [Test] maybes = [ eqProp "isJust" justX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) \ \ WHERE ((NOT (T1.int_b0 IS NULL)) OR (T0.int_a0 = 1))" , eqProp "fromMaybe" maybeX "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, \ \ T1.int_b0 AS f1, T1.may_str_b1 AS f2, T1.str_b2 AS f3 \ \ FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)" ] _p_maybes :: IO () _p_maybes = mapM_ print [show justX, show maybeX] groupX :: Relation () (String, Int64) groupX = aggregateRelation $ proc () -> do c <- query setC -< () gc1 <- groupBy -< c ! strC1' returnA -< gc1 >< count (c ! intC0') cubeX :: Relation () ((Maybe String, Maybe (Int64, Maybe String)), Maybe Int32) cubeX = aggregateRelation $ proc () -> do c <- query setC -< () gCube <- groupBy' -< cube $ proc () -> do arr (uncurry (><)) <<< bkey *** bkey -< (c ! strC1', c ! intC2' >< c ! mayStrC3') returnA -< gCube >< sum' (c ! intC0') groupingSetsX :: Relation () (((Maybe String, Maybe (Maybe String)), Maybe Int64), Maybe Int64) groupingSetsX = aggregateRelation $ proc () -> do c <- query setC -< () gs <- groupBy' -< groupingSets $ proc () -> do s1 <- set -< proc () -> do gRollup <- key' -< rollup $ proc () -> do arr (uncurry (><)) <<< bkey *** bkey -< (c ! strC1', c ! mayStrC3') gc2 <- key -< c ! intC2' returnA -< gRollup >< gc2 s2 <- set -< proc () -> do key -< c ! intC2' returnA -< s1 >< s2 returnA -< gs groups :: [Test] groups = [ eqProp "group" groupX "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \ \ FROM TEST.set_c T0 GROUP BY T0.str_c1" , eqProp "cube" cubeX "SELECT ALL T0.str_c1 AS f0, T0.int_c2 AS f1, T0.may_str_c3 AS f2, SUM(T0.int_c0) AS f3 \ \ FROM TEST.set_c T0 GROUP BY CUBE ((T0.str_c1), (T0.int_c2, T0.may_str_c3))" , eqProp "groupingSets" groupingSetsX "SELECT ALL T0.str_c1 AS f0, T0.may_str_c3 AS f1, T0.int_c2 AS f2, T0.int_c2 AS f3 \ \ FROM TEST.set_c T0 GROUP BY \ \ GROUPING SETS ((ROLLUP ((T0.str_c1), (T0.may_str_c3)), T0.int_c2), (T0.int_c2))" ] _p_groups :: IO () _p_groups = mapM_ print [show groupX, show cubeX, show groupingSetsX] ordFlatX :: Relation () (SetA, Maybe SetB) ordFlatX = relation $ proc () -> do a <- query setA -< () b <- queryMaybe setB -< () on -< just (a ! strA2') .=. b ?! strB2' orderBy Asc -< a ! strA1' orderBy Desc -< b ?! mayStrB1' returnA -< (,) |$| a |*| b ordAggX :: Relation () (String, Int64) ordAggX = aggregateRelation $ proc () -> do c <- query setC -< () gc1 <- groupBy -< c ! strC1' orderBy Asc -< sum' $ c ! intC0' returnA -< gc1 >< count (c ! intC0') _p_orders :: IO () _p_orders = mapM_ print [show ordFlatX, show ordAggX] orders :: [Test] orders = [ eqProp "order-by - flat" ordFlatX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2) \ \ ORDER BY T0.str_a1 ASC, T1.may_str_b1 DESC" , eqProp "order-by - aggregated" ordAggX "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \ \ FROM TEST.set_c T0 GROUP BY T0.str_c1 ORDER BY SUM(T0.int_c0) ASC" ] partitionX :: Relation () (String, Int64) partitionX = relation $ proc () -> do c <- query setC -< () returnA -< (c ! strC1') >< rank `over` proc () -> do partitionBy -< c ! strC1' orderBy Asc -< c ! intC2' partitionY :: Relation () (String, (Int64, Maybe Int32)) partitionY = relation $ proc () -> do c <- query setC -< () returnA -< (c ! strC1') >< (rank >< sum' (c ! intC0')) `over` proc () -> do partitionBy -< c ! strC1' orderBy Asc -< c ! intC2' partitions :: [Test] partitions = [ eqProp "partition 0" partitionX "SELECT ALL T0.str_c1 AS f0, \ \ RANK() OVER (PARTITION BY T0.str_c1 ORDER BY T0.int_c2 ASC) AS f1 \ \ FROM TEST.set_c T0" , eqProp "partition 1" partitionY "SELECT ALL T0.str_c1 AS f0, \ \ RANK() OVER (PARTITION BY T0.str_c1 ORDER BY T0.int_c2 ASC) AS f1, \ \ SUM(T0.int_c0) OVER (PARTITION BY T0.str_c1 ORDER BY T0.int_c2 ASC) AS f2 \ \ FROM TEST.set_c T0" ] _p_partitions :: IO () _p_partitions = mapM_ print [show partitionX, show partitionY] setAFromB :: Pi SetB SetA setAFromB = SetA |$| intB0' |*| strB2' |*| strB2' aFromB :: Relation () SetA aFromB = relation $ proc () -> do x <- query setB -< () returnA -< x ! setAFromB unionX :: Relation () SetA unionX = setA `union` aFromB unionAllX :: Relation () SetA unionAllX = setA `unionAll` aFromB exceptX :: Relation () SetA exceptX = setA `except` aFromB intersectX :: Relation () SetA intersectX = setA `intersect` aFromB exps :: [Test] exps = [ eqProp "union" unionX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a UNION \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" , eqProp "unionAll" unionAllX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a UNION ALL \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" , eqProp "except" exceptX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a EXCEPT \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" , eqProp "intersect" intersectX "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a INTERSECT \ \SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" ] insertX :: Insert SetA insertX = derivedInsert id' insertI :: Insert SetI insertI = derivedInsert id' insertQueryX :: InsertQuery () insertQueryX = derivedInsertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = derivedUpdate $ proc proj -> do assign strA2' -< value "X" wheres -< proj ! strA1' .=. value "A" returnA -< unitPlaceHolder deleteX :: Delete () deleteX = derivedDelete $ proc proj -> do wheres -< proj ! strA1' .=. value "A" returnA -< unitPlaceHolder effs :: [Test] effs = [ eqProp "insert" insertX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)" , eqProp "insert1" insertI "INSERT INTO TEST.set_i (int_i0) VALUES (?)" , eqProp "insertQuery" insertQueryX "INSERT INTO TEST.set_b (int_b0, str_b2, str_b2) SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" , eqProp "updateKey" updateKeyX "UPDATE TEST.set_a SET str_a1 = ?, str_a2 = ? WHERE int_a0 = ?" , eqProp "update" updateX "UPDATE TEST.set_a SET str_a2 = 'X' WHERE (str_a1 = 'A')" , eqProp "delete" deleteX "DELETE FROM TEST.set_a WHERE (str_a1 = 'A')" ] tests :: [Test] tests = concat [ bin, tables, directJoins, join3s, maybes , groups, orders, partitions, exps, effs] main :: IO () main = defaultMain tests relational-query-0.8.3.2/test/Lex.hs0000644000000000000000000000774213000574776015433 0ustar0000000000000000module Lex (eqProp) where import Control.Applicative ((<$>), (<*>), pure, (*>), (<*), (<|>), empty, many, some) import Control.Monad (void) import Control.Monad.Trans.State (StateT (..), evalStateT, get, put) import Control.Monad.Trans.Class (lift) import Data.Maybe (listToMaybe, fromMaybe) import Data.Map (Map) import qualified Data.Map as Map import Test.QuickCheck.Simple (Test, boolTest') type P = StateT String Maybe satisfy' :: (Char -> Bool) -> P Char satisfy' p = do s <- get case s of c:cs -> if p c then put cs *> pure c else empty [] -> empty char' :: Char -> P Char char' x = satisfy' (== x) look' :: P String look' = get eof' :: P () eof' = do s <- get case s of [] -> pure () _:_ -> empty type Var = Int data Token = Qualifier Var | Table Var | Symbol String | Op String | String String | LParen | RParen | Comma | PlaceHolder deriving (Eq, Show) type VarName = String data QState = QState { nextVar :: Var , varMap :: Map VarName Var } deriving Eq type Parser = StateT QState P run' :: Parser a -> String -> Maybe (a, String) run' p = runStateT (evalStateT p (QState { nextVar = 0, varMap = Map.empty })) char :: Char -> Parser Char char = lift . char' satisfy :: (Char -> Bool) -> Parser Char satisfy = lift . satisfy' quote :: Parser Char quote = char '\'' symbolCharset :: [Char] symbolCharset = '_' : ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z'] symbol' :: Parser String symbol' = some $ satisfy (`elem` symbolCharset) symbol :: Parser Token symbol = Symbol <$> symbol' opCharset :: [Char] opCharset = "=<>+-*/|" op :: Parser Token op = Op <$> some (satisfy (`elem` opCharset)) stringChar :: Parser Char stringChar = quote *> quote <|> satisfy (`notElem` ("'().\"")) string :: Parser Token string = String <$> (quote *> many stringChar <* quote) queryVar :: VarName -> Parser Var queryVar n = do s <- get let m = varMap s v' = nextVar s maybe (do put $ QState { nextVar = v' + 1, varMap = Map.insert n v' m } return v') return $ n `Map.lookup` m qualified :: Parser Token qualified = do s <- symbol' void $ char '.' Qualifier <$> queryVar s table :: Parser Token table = do t <- (:) <$> char 'T' <*> some (satisfy (`elem` ['0'..'9'])) Table <$> queryVar t space :: Parser Char space = satisfy (`elem` " \t") someSpaces :: Parser () someSpaces = some space *> pure () spaces :: Parser () spaces = many space *> pure () peekChar :: Parser (Maybe Char) peekChar = listToMaybe <$> lift look' peekSatisfy :: (Char -> Bool) -> Parser Char peekSatisfy pre = do mc <- peekChar case mc of Just c | pre c -> pure c | otherwise -> empty Nothing -> empty symbolSep :: Parser () symbolSep = peekSatisfy (`elem` ("()," ++ opCharset)) *> return () <|> someSpaces <|> eof opSep :: Parser () opSep = peekSatisfy (`elem` symbolCharset) *> return () <|> someSpaces <|> eof lParen :: Parser Token lParen = char '(' *> pure LParen rParen :: Parser Token rParen = char ')' *> pure RParen comma :: Parser Token comma = char ',' *> pure Comma placeholder :: Parser Token placeholder = char '?' *> pure PlaceHolder eof :: Parser () eof = lift eof' token :: Parser Token token = qualified <|> table <* symbolSep <|> symbol <* symbolSep <|> op <* opSep <|> string <|> lParen <|> rParen <|> comma <|> placeholder tokens :: Parser [Token] tokens = (many $ token <* spaces) <* eof run :: String -> Maybe [Token] run = (fst <$>) . run' tokens eq :: String -> String -> Bool eq a b = fromMaybe False $ do x <- run a y <- run b return $ x == y eqProp' :: String -> (t -> String) -> t -> String -> Test eqProp' name t x est = boolTest' name em (t x `eq` est) where em = unlines [show $ run $ t x, " -- compares --", show $ run est] eqProp :: Show a => String -> a -> String -> Test eqProp name = eqProp' name show