relational-query-0.12.2.3/0000755000000000000000000000000013633172100013414 5ustar0000000000000000relational-query-0.12.2.3/relational-query.cabal0000644000000000000000000001663013633172100017703 0ustar0000000000000000name: relational-query version: 0.12.2.3 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-2019 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.8.1, GHC == 8.8.2 , GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3, GHC == 8.6.4, GHC == 8.6.5 , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3, GHC == 8.4.4 , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , 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.Arrow Database.Relational Database.Relational.Table Database.Relational.SimpleSql Database.Relational.Pure Database.Relational.PureUTF8 Database.Relational.NonStandard.PureTimestampTZ Database.Relational.Pi Database.Relational.Pi.Unsafe Database.Relational.Constraint Database.Relational.Context Database.Relational.Config Database.Relational.SqlSyntax Database.Relational.Record Database.Relational.ProjectableClass Database.Relational.Projectable Database.Relational.Projectable.Unsafe Database.Relational.Projectable.Instances Database.Relational.TupleInstances Database.Relational.Monad.BaseType Database.Relational.Monad.Class Database.Relational.Monad.Trans.Ordering Database.Relational.Monad.Trans.Aggregating Database.Relational.Monad.Trans.Restricting Database.Relational.Monad.Trans.Join Database.Relational.Monad.Trans.Config Database.Relational.Monad.Trans.Assigning Database.Relational.Monad.Type Database.Relational.Monad.Simple Database.Relational.Monad.Aggregate Database.Relational.Monad.Unique Database.Relational.Monad.Restrict Database.Relational.Monad.Assign Database.Relational.Monad.Register Database.Relational.Relation Database.Relational.Set Database.Relational.Sequence Database.Relational.Effect Database.Relational.Scalar Database.Relational.Type Database.Relational.Derives Database.Relational.TH -- for GHC version equal or more than 8.0 Database.Relational.OverloadedProjection Database.Relational.OverloadedInstances other-modules: Database.Relational.Internal.ContextType Database.Relational.Internal.Config Database.Relational.Internal.String Database.Relational.Internal.UntypedTable Database.Relational.Internal.Literal Database.Relational.SqlSyntax.Types Database.Relational.SqlSyntax.Join Database.Relational.SqlSyntax.Aggregate Database.Relational.SqlSyntax.Query Database.Relational.SqlSyntax.Fold Database.Relational.SqlSyntax.Updates Database.Relational.Monad.Trans.JoinState Database.Relational.Monad.Trans.Qualify Database.Relational.InternalTH.Base -- for GHC version equal or more than 8.0 Database.Relational.InternalTH.Overloaded build-depends: base <5 , array , containers , transformers , time , time-locale-compat , bytestring , text , dlist , template-haskell , th-reify-compat , th-constraint-compat , product-isomorphic >= 0.0.3 , sql-words >=0.1.5 , names-th , persistable-record >= 0.6 if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* hs-source-dirs: src ghc-options: -Wall -fsimpl-tick-factor=200 if impl(ghc >= 8) ghc-options: -Wcompat if impl(ghc >= 8) && impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite sqls build-depends: base <5 , quickcheck-simple , product-isomorphic , relational-query , containers , transformers if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* type: exitcode-stdio-1.0 main-is: sqlsEq.hs other-modules: Lex Model hs-source-dirs: test ghc-options: -Wall -fsimpl-tick-factor=200 if impl(ghc >= 8) ghc-options: -Wcompat default-language: Haskell2010 test-suite sqlsArrow build-depends: base <5 , quickcheck-simple , product-isomorphic , relational-query , containers , transformers if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* type: exitcode-stdio-1.0 main-is: sqlsEqArrow.hs other-modules: Lex Model hs-source-dirs: test ghc-options: -Wall if impl(ghc >= 8) ghc-options: -Wcompat 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.12.2.3/ChangeLog.md0000644000000000000000000001243113633172100015566 0ustar0000000000000000 ## 0.12.2.3 - update for GHC 8.8.x. - apply compat interface packages of TH. ## 0.12.2.2 - bugfix. fix record width of fromMaybe. ## 0.12.2.1 - fix changelog. ## 0.12.2.0 - add configuration flags to fix problem of correlation. -- Thanks for Yoshikuni Jujo - not import LiteralSQL instance for UTF-8 encoded ByteString by default. - not import LiteralSQL instance for ZonedTime and UTCTime corresponding TIMESTAMPTZ by default. - deprecations of some old APIs. ## 0.12.1.0 - add LiteralSQL instances of word and integer types. ## 0.12.0.1 - update missing of this changelog. ## 0.12.0.0 - rename from ShowConstantTermsSQL to LiteralSQL. - drop #tuplePiM_N. - drop old compat modules for relational-query-0.9.x. ## 0.11.4.0 - add xxxNoPH effect APIs of arrow-interface. ## 0.11.3.0 - add some overloaded projection instances for tuple types. - add #primary overloaded projection instance. ## 0.11.2.0 - add insertValueList API. - (re-)add xxxNoPH effect APIs. - prepare to rename derivedXxx to xxx. - deprecate typed* APIs with implicit defaultConfig. ## 0.11.1.0 - add compatibility module Database.Relational.Query.TH for upgrading from 0.9. ## 0.11.0.0 - same as 0.10.1.1. re-versioned for TH incompatibility against 0.10.0. ## 0.10.1.1 - fix overloaded-labels instances for GHC 8.2. ## 0.10.1.0 - define projections with overloaded-labels. -- Thanks for Ryan Mulligan - add a portable sequence number operation. ## 0.10.0.0 - switch namespace to Database.Relational - update interfaces about projection types. - divide and apply product-isomorphic interfaces. ## 0.9.5.0 - export QuerySuffix and unsafe-query functions from Database.Relational.Query namespace for libraries. ## 0.9.4.1 - fix version constraint. ## 0.9.4.0 - add NULLS FIRST and NULLS LAST to ORDER BY clause. ## 0.9.3.0 - add Show instance of Pi. - add pzero and ConstantTermsSQL instance of (). - add Category instance of Pi. ## 0.9.2.1 - add tested-with 8.2.1. ## 0.9.2.0 - Add derivedInsertValue definitions to arrow interface. - Apply chunked-insert to derivedInsertValue. ## 0.9.1.0 - Fix of unsafeValueNull. ( https://github.com/khibino/haskell-relational-record/issues/55 ) ## 0.9.0.2 - Bugfix of case projected record. ( https://github.com/khibino/haskell-relational-record/issues/54 ) ## 0.9.0.1 - Use Haskell implementation test instead of flag test in .cabal ## 0.9.0.0 - Add HRR instances of tuple types derived by generic programming. - Add generic instances of ShowConstantTermsSQL. ## 0.8.3.6 - Bugfix of lazy instances of ShowConstantTermsSQL. ## 0.8.3.5 - Deprecate some exported interfaces which are internal definitions. ## 0.8.3.4 - Update this changelog ## 0.8.3.3 - simpl-tick-factor work-around to avoid bug of GHC ## 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 ## 0.4.0.0 - Extend derivedInsert. ## 0.3.0.0 - Add generalized restrict. - Pass configuration to DELETE and UPDATE. ## 0.2.0.0 - Update structure of query with placeholders. relational-query-0.12.2.3/Setup.hs0000644000000000000000000000005613633172100015051 0ustar0000000000000000import Distribution.Simple main = defaultMain relational-query-0.12.2.3/LICENSE0000644000000000000000000000275613633172100014433 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.12.2.3/src/0000755000000000000000000000000013633172100014203 5ustar0000000000000000relational-query-0.12.2.3/src/Database/0000755000000000000000000000000013633172100015707 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational.hs0000644000000000000000000001002013633172100020326 0ustar0000000000000000-- | -- Module : Database.Relational -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module is integrated module of Query. module Database.Relational ( module Database.Relational.Table, module Database.Relational.SimpleSql, module Database.Relational.Pi, module Database.Relational.Constraint, module Database.Relational.Context, module Database.Relational.Config, module Database.Relational.SqlSyntax, module Database.Relational.Record, module Database.Relational.ProjectableClass, module Database.Relational.Projectable, module Database.Relational.TupleInstances, module Database.Relational.Monad.BaseType, module Database.Relational.Monad.Class, module Database.Relational.Monad.Trans.Ordering, module Database.Relational.Monad.Trans.Aggregating, module Database.Relational.Monad.Trans.Assigning, module Database.Relational.Monad.Type, module Database.Relational.Monad.Simple, module Database.Relational.Monad.Aggregate, module Database.Relational.Monad.Restrict, module Database.Relational.Monad.Unique, module Database.Relational.Monad.Assign, module Database.Relational.Monad.Register, module Database.Relational.Relation, module Database.Relational.Set, module Database.Relational.Sequence, module Database.Relational.Scalar, module Database.Relational.Type, module Database.Relational.Effect, module Database.Relational.Derives ) where import Database.Relational.Table (Table, TableDerivable (..)) import Database.Relational.SimpleSql (QuerySuffix, updateOtherThanKeySQL) import Database.Relational.Pure () import Database.Relational.Pi import Database.Relational.Constraint (Key, tableConstraint, projectionKey, uniqueKey, -- notNullKey, HasConstraintKey(constraintKey), derivedUniqueKey, -- derivedNotNullKey, Primary, Unique, NotNull) import Database.Relational.Context import Database.Relational.Config import Database.Relational.SqlSyntax (Order (..), Nulls (..), AggregateKey, Record, Predicate, PI, SubQuery, unitSQL, queryWidth, ) import Database.Relational.Record (RecordList, list) import Database.Relational.ProjectableClass import Database.Relational.Projectable import Database.Relational.TupleInstances import Database.Relational.Monad.BaseType import Database.Relational.Monad.Class (MonadQualify, MonadRestrict, wheres, having, restrict, MonadAggregate, groupBy, groupBy', MonadQuery, query', queryMaybe', MonadPartition, partitionBy, distinct, all', on) import Database.Relational.Monad.Trans.Ordering (Orderings, orderBy', orderBy, asc, desc) import Database.Relational.Monad.Trans.Aggregating (key, key', set, bkey, rollup, cube, groupingSets) import Database.Relational.Monad.Trans.Assigning (assignTo, (<-#)) import Database.Relational.Monad.Type import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery) import Database.Relational.Monad.Aggregate (QueryAggregate, AggregatedQuery, Window, over) import Database.Relational.Monad.Restrict (Restrict) import Database.Relational.Monad.Unique (QueryUnique) import Database.Relational.Monad.Assign (Assign) import Database.Relational.Monad.Register (Register) import Database.Relational.Relation import Database.Relational.Set import Database.Relational.Sequence import Database.Relational.Scalar (ScalarDegree) import Database.Relational.Type hiding (unsafeTypedKeyUpdate, unsafeTypedDelete, unsafeTypedInsert, unsafeTypedInsertQuery, ) import Database.Relational.Effect (Restriction, restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn, liftTargetAllColumn', InsertTarget, insertTarget', piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList, insertTarget, updateTarget, updateTargetAllColumn, updateTargetAllColumn', sqlWhereFromRestriction, sqlFromUpdateTarget, ) import Database.Relational.Derives import Database.Record.Instances () {-# ANN module "HLint: ignore Use import/export shortcut" #-} relational-query-0.12.2.3/src/Database/Relational/0000755000000000000000000000000013633172100020001 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/Pure.hs0000644000000000000000000001041713633172100021253 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Pure -- Copyright : 2013-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines instances which lift from haskell pure values -- to query internal record values. module Database.Relational.Pure () where import Control.Applicative (pure) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64, Word) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Text.Printf (PrintfArg, printf) import Data.Time (Day, TimeOfDay, LocalTime) import Data.DList (DList, fromList) import Language.SQL.Keyword (Keyword (..)) import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Internal.String (StringSQL, stringSQL) import qualified Database.Relational.Internal.Literal as Lit import Database.Relational.ProjectableClass (LiteralSQL (..)) -- | Constant SQL terms of '()'. instance LiteralSQL () -- | Constant SQL terms of 'Int8'. instance LiteralSQL Int8 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Int16'. instance LiteralSQL Int16 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Int32'. instance LiteralSQL Int32 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Int64'. instance LiteralSQL Int64 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Int'. -- Use this carefully, because this is architecture dependent size of integer type. instance LiteralSQL Int where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Word8'. instance LiteralSQL Word8 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Word16'. instance LiteralSQL Word16 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Word32'. instance LiteralSQL Word32 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Word64'. instance LiteralSQL Word64 where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'Word'. -- Use this carefully, because this is architecture dependent size of integer type. instance LiteralSQL Word where showLiteral' = pure . Lit.integral instance LiteralSQL Integer where showLiteral' = pure . Lit.integral -- | Constant SQL terms of 'String'. instance LiteralSQL String where showLiteral' = pure . Lit.stringExpr -- | Constant SQL terms of 'Text'. instance LiteralSQL Text where showLiteral' = pure . Lit.stringExpr . T.unpack -- | Constant SQL terms of 'LT.Text'. instance LiteralSQL LT.Text where showLiteral' = pure . Lit.stringExpr . LT.unpack -- | Constant SQL terms of 'Char'. instance LiteralSQL Char where showLiteral' = pure . Lit.stringExpr . (:"") -- | Constant SQL terms of 'Bool'. instance LiteralSQL Bool where showLiteral' = pure . Lit.bool floatTerms :: (PrintfArg a, Ord a, Num a)=> a -> DList StringSQL floatTerms f = pure . stringSQL $ printf fmt f where fmt | f >= 0 = "%f" | otherwise = "(%f)" -- | Constant SQL terms of 'Float'. Caution for floating-point error rate. instance LiteralSQL Float where showLiteral' = floatTerms -- | Constant SQL terms of 'Double'. Caution for floating-point error rate. instance LiteralSQL Double where showLiteral' = floatTerms -- | Constant SQL terms of 'Day'. instance LiteralSQL Day where showLiteral' = pure . Lit.timestamp DATE "%Y-%m-%d" -- | Constant SQL terms of 'TimeOfDay'. instance LiteralSQL TimeOfDay where showLiteral' = pure . Lit.timestamp TIME "%H:%M:%S" -- | Constant SQL terms of 'LocalTime'. instance LiteralSQL LocalTime where showLiteral' = pure . Lit.timestamp TIMESTAMP "%Y-%m-%d %H:%M:%S" showMaybeTerms :: LiteralSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL showMaybeTerms wa = d where d (Just a) = showLiteral' a d Nothing = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL" -- | Constant SQL terms of 'Maybe' type. Width inference is required. instance (PersistableWidth a, LiteralSQL a) => LiteralSQL (Maybe a) where showLiteral' = showMaybeTerms persistableWidth relational-query-0.12.2.3/src/Database/Relational/Config.hs0000644000000000000000000000112513633172100021541 0ustar0000000000000000-- | -- Module : Database.Relational.Config -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides untyped components for query. module Database.Relational.Config ( -- * Configuration type for query module Database.Relational.Internal.Config, ) where import Database.Relational.Internal.Config (NameConfig (..), ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), Config (..), defaultConfig, defaultNameConfig) relational-query-0.12.2.3/src/Database/Relational/Relation.hs0000644000000000000000000001571313633172100022121 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Relation -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module integrate monadic operations to compose complex queries -- with re-usable Relation type. module Database.Relational.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', ) where import Control.Applicative ((<$>)) import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.SqlSyntax (NodeAttr(Just', Maybe), Record, ) import Database.Relational.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, unsafeTypeRelation, untypeRelation, relationWidth) import Database.Relational.Monad.Class (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), ) import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery) import qualified Database.Relational.Monad.Simple as Simple import Database.Relational.Monad.Aggregate (QueryAggregate, AggregatedQuery) import qualified Database.Relational.Monad.Aggregate as Aggregate import Database.Relational.Monad.Unique (QueryUnique, unsafeUniqueSubQuery) import qualified Database.Relational.Monad.Unique as Unique import Database.Relational.Table (Table, TableDerivable, derivedTable) import qualified Database.Relational.Table as Table import Database.Relational.Scalar (ScalarDegree) import Database.Relational.Pi (Pi) import Database.Relational.Record (RecordList) import qualified Database.Relational.Record as Record import Database.Relational.Projectable (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, ) -- | Simple 'Relation' from 'Table'. table :: Table r -> Relation () r table = unsafeTypeRelation . return . Table.toSubQuery -- | Inferred '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 (Record 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 (Record Flat (Maybe r)) queryMaybe = fmap snd . queryMaybe' queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (RecordList (Record c) r) queryList0 = liftQualify . fmap Record.unsafeListFromSubQuery . untypeRelation -- | List sub-query, for /IN/ and /EXIST/ with place-holder parameter 'p'. queryList' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, RecordList (Record 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 (RecordList (Record 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 (Record 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 (Record Aggregated r) -> Relation () r aggregateRelation = aggregateRelation' . addUnitPH -- | 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, Record c r) uniqueQueryWithAttr attr = unsafeAddPlaceHolders . run where run rel = do q <- liftQualify $ do sq <- untypeRelation (unUnique rel) qualifyQuery sq Record.unsafeChangeContext <$> unsafeUniqueSubQuery attr q -- | Join unique sub-query with place-holder parameter 'p'. uniqueQuery' :: UniqueRelation p c r -> QueryUnique (PlaceHolders p, Record 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, Record c (Maybe r)) uniqueQueryMaybe' pr = do (ph, pj) <- uniqueQueryWithAttr Maybe pr return (ph, Record.just pj) -- | Finalize 'QueryUnique' monad and generate 'UniqueRelation'. uniqueRelation' :: QueryUnique (PlaceHolders p, Record c r) -> UniqueRelation p c r uniqueRelation' = unsafeUnique . unsafeTypeRelation . Unique.toSubQuery -- | Aggregated 'UniqueRelation'. aggregatedUnique :: Relation ph r -> Pi r a -> (Record Flat a -> Record Aggregated b) -> UniqueRelation ph Flat b aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do (ph, a) <- query' rel return (ph, ag $ Record.wpi (relationWidth rel) a k) -- | Scalar sub-query with place-holder parameter 'p'. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation p c r -> m (PlaceHolders p, Record c (Maybe r)) queryScalar' ur = unsafeAddPlaceHolders . liftQualify $ Record.unsafeFromScalarSubQuery <$> untypeRelation (unUnique ur) -- | Scalar sub-query. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> m (Record c (Maybe r)) queryScalar = fmap snd . queryScalar' relational-query-0.12.2.3/src/Database/Relational/SimpleSql.hs0000644000000000000000000000674213633172100022257 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.SimpleSql -- Copyright : 2013-2017 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.SimpleSql ( -- * Query suffix QuerySuffix, showsQuerySuffix, -- * Update SQL updatePrefixSQL, updateOtherThanKeySQL, -- * Insert SQL insertPrefixSQL, -- * Delete SQL 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.Internal.String (StringSQL, stringSQL, showStringSQL, rowConsStringSQL, ) import Database.Relational.Pi (Pi, expandIndexes') import Database.Relational.Table (Table, name, columns, recordWidth) import qualified Database.Relational.Record as Record -- | 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 -> [StringSQL] -- ^ Column name list to update -> [StringSQL] -- ^ Key column name list -> String -- ^ Result SQL updateSQL' table cols key = showStringSQL $ mconcat [UPDATE, stringSQL table, SET, SQL.fold (|*|) updAssigns, WHERE, SQL.fold SQL.and keyAssigns] where assigns cs = [ 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 -> [StringSQL] -- ^ 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) (expandIndexes' (recordWidth tbl) key) -- | Generate prefix string of insert SQL. insertPrefixSQL :: Pi r r' -> Table r -> StringSQL insertPrefixSQL pi' table = INSERT <> INTO <> stringSQL (name table) <> rowConsStringSQL cols where cols = Record.columns . Record.wpi (recordWidth table) (Record.unsafeFromTable table) $ pi' -- | 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.12.2.3/src/Database/Relational/Derives.hs0000644000000000000000000001155013633172100021740 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Derives -- Copyright : 2013-2017 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.Derives ( -- * Query derivation specifiedKey, uniqueSelect, primarySelect, -- * Update derivation updateByConstraintKey, primaryUpdate, updateValuesWithKey, -- * Derived objects from table derivedUniqueRelation, -- * Deprecated unique, primary', primary, ) where import Database.Record (PersistableWidth, ToSql) import Database.Record.ToSql (unsafeUpdateValuesWithIndexes) import Database.Relational.SqlSyntax (Record) import Database.Relational.Table (Table, TableDerivable) import Database.Relational.Pi (Pi, expandIndexes) import qualified Database.Relational.Record as Record import Database.Relational.Projectable (placeholder, (.=.), (!)) import Database.Relational.Monad.Class (wheres) import Database.Relational.Monad.BaseType (Relation, relationWidth) import Database.Relational.Relation (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) import Database.Relational.Constraint (Key, Primary, Unique, projectionKey, uniqueKey, HasConstraintKey(constraintKey)) import qualified Database.Relational.Constraint as Constraint import Database.Relational.Type (KeyUpdate, typedKeyUpdate) -- | Query restricted with specified key. specifiedKey :: PersistableWidth p => Pi a p -- ^ Projection path -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' specifiedKey key rel = relation' $ do q <- query rel (param, ()) <- placeholder (\ph -> wheres $ Record.wpi (relationWidth rel) q key .=. ph) return (param, q) -- | Query restricted with specified unique key. uniqueSelect :: 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' uniqueSelect = specifiedKey . projectionKey {-# DEPRECATED unique "use `uniqueSelect` instead of this." #-} -- | Deprecated. unique :: PersistableWidth p => Key Unique a p -> Relation () a -> Relation p a unique = uniqueSelect {-# DEPRECATED primary' "use `primarySelect` instead of this." #-} -- | Deprecated. 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. primarySelect :: HasConstraintKey Primary a p => Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' primarySelect = primary' constraintKey {-# DEPRECATED primary "use `primarySelect` instead of this." #-} -- | Deprecated. primary :: HasConstraintKey Primary a p => Relation () a -> Relation p a primary = primarySelect -- | 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 . expandIndexes -- | 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'. -> Record 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 .=. Record.unsafeChangeContext kp return r relational-query-0.12.2.3/src/Database/Relational/OverloadedInstances.hs0000644000000000000000000000162013633172100024270 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} -- | -- Module : Database.Relational.OverloadedInstances -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides basic instances of overloaded projections like tuples.. module Database.Relational.OverloadedInstances () where import Control.Applicative ((<$>)) #if __GLASGOW_HASKELL__ >= 800 import Database.Relational.OverloadedProjection (projection) #endif import Database.Relational.InternalTH.Overloaded (tupleProjection) $(concat <$> mapM tupleProjection [2 .. 7]) -- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics. relational-query-0.12.2.3/src/Database/Relational/TH.hs0000644000000000000000000005735213633172100020664 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE CPP #-} -- | -- Module : Database.Relational.TH -- Copyright : 2013-2019 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.TH ( -- * All templates about table defineTable, -- * Inlining typed 'Query' unsafeInlineQuery, inlineQuery, -- * Column projections and basic 'Relation' for Haskell record defineTableTypesAndRecord, -- * Constraint key templates defineHasPrimaryKeyInstance, defineHasPrimaryKeyInstanceWithConfig, defineHasNotNullKeyInstance, defineHasNotNullKeyInstanceWithConfig, defineScalarDegree, -- * Column projections defineColumnsDefault, defineOverloadedColumnsDefault, defineColumns, defineOverloadedColumns, defineTuplePi, -- * Table metadata type and basic 'Relation' defineTableTypes, defineTableTypesWithConfig, -- * Basic SQL templates generate rules definePrimaryQuery, definePrimaryUpdate, -- * Var expression templates derivationExpDefault, tableVarExpDefault, relationVarExp, -- * Derived SQL templates from table definitions defineSqlsWithPrimaryKey, defineSqlsWithPrimaryKeyDefault, -- * Reify makeRelationalRecordDefault, makeRelationalRecordDefault', reifyRelation, ) where import Data.Char (toUpper, toLower) import Data.List (foldl1') import Data.Array.IArray ((!)) import Data.Functor.ProductIsomorphic.TH (reifyRecordType, defineProductConstructor) import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..)) import Language.Haskell.TH (Name, nameBase, Q, reify, Dec, instanceD, ExpQ, stringE, listE, TypeQ, Type (AppT, ConT), varT, tupleT, appT, arrowT) import Language.Haskell.TH.Compat.Reify (unVarI) import Language.Haskell.TH.Compat.Constraint (classP) import Language.Haskell.TH.Name.CamelCase (VarName, varName, ConName (ConName), conName, varCamelcaseName, toVarExp, toTypeCon) import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE) import Database.Record.TH (columnOffsetsVarNameDefault, recordTypeName, recordTemplate, defineRecordTypeWithConfig, defineHasColumnConstraintInstance) import qualified Database.Record.TH as Record import Database.Relational (Table, Pi, id', Relation, LiteralSQL, NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..), defaultConfig, Config (normalizedTableName, disableOverloadedProjection, disableSpecializedProjection, schemaNameMode, nameConfig, identifierQuotation), Query, untypeQuery, relationalQuery_, relationalQuery, KeyUpdate, Insert, insert, InsertQuery, insertQuery, HasConstraintKey(constraintKey), Primary, NotNull, primarySelect, primaryUpdate) import Database.Relational.InternalTH.Base (defineTuplePi, defineRecordProjections) import Database.Relational.Scalar (defineScalarDegree) import Database.Relational.Constraint (unsafeDefineConstraintKey) import Database.Relational.Table (TableDerivable (..)) import qualified Database.Relational.Table as Table import Database.Relational.Relation (derivedRelation) import Database.Relational.SimpleSql (QuerySuffix) import Database.Relational.Type (unsafeTypedQuery) import qualified Database.Relational.Pi.Unsafe as UnsafePi import qualified Database.Relational.InternalTH.Overloaded as Overloaded -- | 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 = [d| instance HasConstraintKey $constraint $recType $colType where constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes]) |] -- | 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 pp <- Overloaded.definePrimaryHasProjection recType colType indexes return $ kc ++ ck ++ pp -- | 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 . fst . recordTemplate (recordConfig $ nameConfig config) scm -- | 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 . fst . recordTemplate (recordConfig $ nameConfig config) scm projectionTemplate :: ConName -- ^ Record type name -> VarName -- ^ Column declaration variable name -> Int -- ^ Column leftest index -> TypeQ -- ^ Column type -> Q [Dec] -- ^ Column projection path declaration projectionTemplate recName var ix colType = do let offsetsExp = toVarExp . columnOffsetsVarNameDefault $ conName recName simpleValD (varName var) [t| Pi $(toTypeCon recName) $colType |] [| UnsafePi.definePi $ $offsetsExp ! $(integralE ix) |] -- | Projection path 'Pi' templates. defineColumns :: ConName -- ^ Record type name -> [(VarName, TypeQ)] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineColumns recTypeName cols = do let defC (name, typ) ix = projectionTemplate recTypeName name ix typ fmap concat . sequence $ zipWith defC cols [0 :: Int ..] -- | Overloaded projection path 'Pi' templates. defineOverloadedColumns :: ConName -- ^ Record type name -> [(String, TypeQ)] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineOverloadedColumns recTypeName cols = do let defC (name, typ) ix = Overloaded.monomorphicProjection recTypeName name ix typ fmap concat . sequence $ zipWith defC cols [0 :: Int ..] -- | Make projection path templates using default naming rule. defineColumnsDefault :: ConName -- ^ Record type name -> [(String, TypeQ)] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineColumnsDefault recTypeName cols = defineColumns recTypeName [ (varCamelcaseName $ name ++ "'", typ) | (name, typ) <- cols ] -- | Make overloaded projection path templates using default naming rule. defineOverloadedColumnsDefault :: ConName -- ^ Record type name -> [(String, TypeQ)] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineOverloadedColumnsDefault recTypeName cols = defineOverloadedColumns recTypeName [ (nameBase . varName $ varCamelcaseName name, typ) | (name, typ) <- cols ] -- | 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' |] [| insert id' |] let insQVar = varName insQVar' insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType' -> InsertQuery p |] [| insertQuery 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])) varNameWithPrefix :: String -> String -> VarName varNameWithPrefix n p = varCamelcaseName $ p ++ "_" ++ n 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 -- | Make template for record 'ProductConstructor' instance using specified naming rule. defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [Q Type] -> Q [Dec] defineProductConstructorInstanceWithConfig config schema table colTypes = do let (recType, recData) = recordTemplate (recordConfig $ nameConfig config) schema table [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recType colTypes) where productConstructor = $(recData) |] -- | 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)] -- ^ 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") (fst $ recordTemplate recConfig schema table) (tableSQL (normalizedTableName config) (schemaNameMode config) (identifierQuotation config) schema table) (map ((quote (identifierQuotation config)) . fst) columns) let typeName = recordTypeName recConfig schema table colsDs <- if disableSpecializedProjection config then [d| |] else defineColumnsDefault typeName columns pcolsDs <- if disableOverloadedProjection config then [d| |] else defineOverloadedColumnsDefault typeName columns return $ tableDs ++ colsDs ++ pcolsDs -- | 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 let recConfig = recordConfig $ nameConfig config recD <- defineRecordTypeWithConfig recConfig schema table columns derives rconD <- defineProductConstructorInstanceWithConfig config schema table [t | (_, t) <- columns] ctD <- [d| instance LiteralSQL $(fst $ recordTemplate recConfig schema table) |] tableDs <- defineTableTypesWithConfig config schema table columns return $ recD ++ rconD ++ ctD ++ tableDs -- | 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 (primarySelect $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 = fst $ recordTemplate (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 -- | 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) (untypeQuery $ relationalQuery_ config rel sufs) (varCamelcaseName qns) -- | Generate all templates against defined record like type constructor -- other than depending on sql-value type. makeRelationalRecordDefault' :: Config -> Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration makeRelationalRecordDefault' config recTypeName = do let recTypeConName = ConName recTypeName (((tyCon, vars), _dataCon), (mayNs, cts)) <- reifyRecordType recTypeName pw <- Record.definePersistableWidthInstance tyCon vars cols <- case mayNs of Nothing -> return [] Just ns -> case vars of [] -> do {- monomorphic case -} off <- Record.defineColumnOffsets recTypeConName let cnames = [ (nameBase n, ct) | n <- ns | ct <- cts ] cs <- if disableSpecializedProjection config then [d| |] else defineColumnsDefault recTypeConName cnames pcs <- if disableOverloadedProjection config then [d| |] else defineOverloadedColumnsDefault recTypeConName cnames return $ off ++ cs ++ pcs _:_ -> do {- polymorphic case -} cols <- if disableSpecializedProjection config then [d| |] else defineRecordProjections tyCon vars [varName $ varCamelcaseName (nameBase n ++ "'") | n <- ns] cts ovls <- if disableOverloadedProjection config then [d| |] else Overloaded.polymorphicProjections tyCon vars [nameBase n | n <- ns] cts return $ cols ++ ovls pc <- defineProductConstructor recTypeName let scPred v = classP ''LiteralSQL [varT v] ct <- instanceD (mapM scPred vars) (appT [t| LiteralSQL |] tyCon) [] return $ concat [pw, cols, pc, [ct]] -- | 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 = makeRelationalRecordDefault' defaultConfig relational-query-0.12.2.3/src/Database/Relational/Type.hs0000644000000000000000000004620013633172100021260 0ustar0000000000000000-- | -- Module : Database.Relational.Type -- Copyright : 2013-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed SQL. module Database.Relational.Type ( -- * Typed query statement Query (..), unsafeTypedQuery, relationalQuery_, relationalQuery', relationalQuery, relationalQuerySQL, -- * Typed update statement KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, keyUpdate, Update (..), unsafeTypedUpdate, typedUpdate', update', update, updateNoPH, typedUpdateAllColumn, updateAllColumn', updateAllColumn, updateAllColumnNoPH, updateSQL, -- * Typed insert statement Insert (..), untypeChunkInsert, chunkSizeOfInsert, unsafeTypedInsert', unsafeTypedInsert, typedInsert', insert, typedInsertValue', insertValue', insertValue, insertValueNoPH, insertValueList', insertValueList, InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', insertQuery', insertQuery, insertQuerySQL, -- * Typed delete statement Delete (..), unsafeTypedDelete, typedDelete', delete', delete, deleteNoPH, deleteSQL, -- * Generalized interfaces UntypeableNoFetch (..), -- * Deprecated typedUpdate, typedInsert, typedInsertValue, typedInsertQuery, typedDelete, derivedKeyUpdate, derivedUpdate', derivedUpdate, derivedUpdateAllColumn', derivedUpdateAllColumn, derivedInsert, derivedInsertValue', derivedInsertValue, derivedInsertQuery, derivedDelete', derivedDelete, ) where import Data.Monoid ((<>)) import Data.Functor.ProductIsomorphic (peRight) import Database.Record (PersistableWidth) import Database.Relational.Internal.Config (Config, defaultConfig) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.Internal.String (showStringSQL) import Database.Relational.SqlSyntax (Record) import Database.Relational.Monad.BaseType (Relation, sqlFromRelationWith) import Database.Relational.Monad.Restrict (Restrict) import Database.Relational.Monad.Assign (Assign) import Database.Relational.Monad.Register (Register) import Database.Relational.Relation (tableOf) import Database.Relational.Effect (liftTargetAllColumn', InsertTarget, insertTarget', deleteFromRestriction, updateFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList) import Database.Relational.Pi (Pi) import Database.Relational.Table (Table, TableDerivable, derivedTable) import Database.Relational.ProjectableClass (LiteralSQL) import Database.Relational.Projectable (PlaceHolders, unitPH) import Database.Relational.SimpleSql (QuerySuffix, showsQuerySuffix, insertPrefixSQL, updateOtherThanKeySQL, ) -- | 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_ :: Config -> Relation p r -> QuerySuffix -> Query p r relationalQuery_ config rel qsuf = unsafeTypedQuery $ relationalQuerySQL config rel qsuf -- | From 'Relation' into typed 'Query' with suffix SQL words. relationalQuery' :: Relation p r -> QuerySuffix -> Query p r relationalQuery' = relationalQuery_ defaultConfig -- | 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 -- keyUpdate' -- Config parameter is not yet required for KeyUpdate. -- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'. keyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r keyUpdate = typedKeyUpdate derivedTable {-# DEPRECATED derivedKeyUpdate "use keyUpdate instead of this." #-} -- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'. derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r derivedKeyUpdate = keyUpdate -- | 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 'Assign' computation. updateSQL :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> String updateSQL config tbl ut = showStringSQL $ updateFromUpdateTarget config tbl ut -- | Make typed 'Update' from 'Config', 'Table' and 'Assign' computation. typedUpdate' :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p typedUpdate' config tbl ut = unsafeTypedUpdate $ updateSQL config tbl ut {-# DEPRECATED typedUpdate "use `typedUpdate' defaultConfig` instead of this." #-} -- | Make typed 'Update' using 'defaultConfig', 'Table' and 'Assign' computation. typedUpdate :: Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p typedUpdate = typedUpdate' defaultConfig targetTable :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Table r targetTable = const derivedTable -- | Make typed 'Update' from 'Config', derived table and 'Assign' computation. update' :: TableDerivable r => Config -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p update' config ac = typedUpdate' config (targetTable ac) ac {-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-} -- | Make typed 'Update' from 'Config', derived table and 'Assign' computation. derivedUpdate' :: TableDerivable r => Config -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p derivedUpdate' = update' -- | Make typed 'Update' from 'defaultConfig', derived table and 'Assign' computation. update :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Update p update = update' defaultConfig -- | Make typed 'Update' from 'defaultConfig', derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r => (Record Flat r -> Assign r ()) -> Update () updateNoPH af = update $ (>> return unitPH) . af {-# DEPRECATED derivedUpdate "use `update` instead of this." #-} -- | Make typed 'Update' from 'defaultConfig', derived table and 'Assign' computation. derivedUpdate :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Update p derivedUpdate = update -- | Make typed 'Update' from 'Config', 'Table' and 'Restrict' computation. -- Update target is all column. typedUpdateAllColumn' :: PersistableWidth r => Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Update (r, p) typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r -- | Make typed 'Update' from 'Table' and 'Restrict' computation. -- Update target is all column. typedUpdateAllColumn :: PersistableWidth r => Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Update (r, p) typedUpdateAllColumn = typedUpdateAllColumn' defaultConfig -- | Make typed 'Update' from 'Config', derived table and 'Restrict' computation. -- Update target is all column. updateAllColumn' :: (PersistableWidth r, TableDerivable r) => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Update (r, p) updateAllColumn' config = typedUpdateAllColumn' config derivedTable {-# DEPRECATED derivedUpdateAllColumn' "use `updateAllColumn'` instead of this." #-} -- | Deprecated. use 'updateAllColumn''. derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r) => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Update (r, p) derivedUpdateAllColumn' = updateAllColumn' -- | Make typed 'Update' from 'defaultConfig', derived table and 'Restrict' computation. -- Update target is all column. updateAllColumn :: (PersistableWidth r, TableDerivable r) => (Record Flat r -> Restrict (PlaceHolders p)) -> Update (r, p) updateAllColumn = updateAllColumn' defaultConfig -- | Make typed 'Update' from 'defaultConfig', derived table and 'Restrict' computation -- without placeholder other than target table columns. -- Update target is all column. updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r) => (Record Flat r -> Restrict ()) -> Update r updateAllColumnNoPH = typedUpdate' defaultConfig derivedTable . (fmap peRight .) . liftTargetAllColumn' . ((>> return unitPH) .) {-# DEPRECATED derivedUpdateAllColumn "use `updateAllColumn` instead of this." #-} -- | Deprecated. use 'updateAllColumn'. derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r) => (Record Flat r -> Restrict (PlaceHolders p)) -> Update (r, p) derivedUpdateAllColumn = updateAllColumn -- | 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' :: PersistableWidth r => Config -> Table r -> Pi r r' -> Insert r' typedInsert' config tbl = typedInsertValue' config tbl . insertTarget' . piRegister {-# DEPRECATED typedInsert "use `typedInsert' defaultConfig` instead of this." #-} -- | Make typed 'Insert' from 'Table' and columns selector 'Pi'. typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r' typedInsert = typedInsert' defaultConfig -- | Table type inferred 'Insert'. insert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' insert = typedInsert' defaultConfig derivedTable {-# DEPRECATED derivedInsert "use `insert` instead of this." #-} -- | Table type inferred 'Insert'. derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' derivedInsert = insert -- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p typedInsertValue' config tbl it = unsafeTypedInsert' (showStringSQL $ sqlFromInsertTarget config tbl it) (showStringSQL ci) n where (ci, n) = sqlChunkFromInsertTarget config tbl it {-# DEPRECATED typedInsertValue "use `typedInsertValue' defaultConfig` instead of this." #-} -- | 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. insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p insertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs where rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r rt = const derivedTable {-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-} -- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p derivedInsertValue' = insertValue' -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p insertValue = insertValue' defaultConfig -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r => Register r () -> Insert () insertValueNoPH = insertValue . (>> return unitPH) {-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-} -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p derivedInsertValue = insertValue -- | Make typed 'Insert' list from 'Config' and records list. insertValueList' :: (TableDerivable r, LiteralSQL r') => Config -> Pi r r' -> [r'] -> [Insert ()] insertValueList' config pi' = map (unsafeTypedInsert . showStringSQL) . sqlChunksFromRecordList config derivedTable pi' -- | Make typed 'Insert' list from records list. insertValueList :: (TableDerivable r, LiteralSQL r') => Pi r r' -> [r'] -> [Insert ()] insertValueList = insertValueList' 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 {-# DEPRECATED typedInsertQuery "use `typedInsertQuery' defaultConfig` instead of this." #-} -- | 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'. insertQuery' :: TableDerivable r => Config -> Pi r r' -> Relation p r' -> InsertQuery p insertQuery' config = typedInsertQuery' config derivedTable -- | Table type inferred 'InsertQuery' with 'defaultConfig'. insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' defaultConfig {-# DEPRECATED derivedInsertQuery "use `insertQuery` instead of this." #-} -- | Table type inferred 'InsertQuery'. derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p derivedInsertQuery = insertQuery -- | 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 'Restrict' computation. deleteSQL :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> String deleteSQL config tbl r = showStringSQL $ deleteFromRestriction config tbl r -- | Make typed 'Delete' from 'Config', 'Table' and 'Restrict' computation. typedDelete' :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p typedDelete' config tbl r = unsafeTypedDelete $ deleteSQL config tbl r {-# DEPRECATED typedDelete "use `typedDelete' defaultConfig` instead of this." #-} -- | Make typed 'Delete' from 'Table' and 'Restrict' computation. typedDelete :: Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p typedDelete = typedDelete' defaultConfig restrictedTable :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Table r restrictedTable = const derivedTable -- | Make typed 'Delete' from 'Config', derived table and 'Restrict' computation. delete' :: TableDerivable r => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p delete' config rc = typedDelete' config (restrictedTable rc) rc {-# DEPRECATED derivedDelete' "use `delete'` instead of this." #-} -- | Make typed 'Delete' from 'Config', derived table and 'Restrict' computation. derivedDelete' :: TableDerivable r => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p derivedDelete' = delete' -- | Make typed 'Delete' from 'defaultConfig', derived table and 'Restrict' computation. delete :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p delete = delete' defaultConfig -- | Make typed 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r => (Record Flat r -> Restrict ()) -> Delete () deleteNoPH rf = delete $ (>> return unitPH) . rf {-# DEPRECATED derivedDelete "use `delete` instead of this." #-} -- | Make typed 'Delete' from 'defaultConfig', derived table and 'Restrict' computation. derivedDelete :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p derivedDelete = delete -- | 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.12.2.3/src/Database/Relational/Constraint.hs0000644000000000000000000000771313633172100022471 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Constraint -- Copyright : 2013-2017 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.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.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) import Database.Record.KeyConstraint (KeyConstraint, unsafeSpecifyKeyConstraint, Primary, Unique, NotNull) import qualified Database.Record.KeyConstraint as C import Database.Relational.Pi (Pi) import qualified Database.Relational.Pi.Unsafe as UnsafePi -- | 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 -- | Inferred '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 -- -- | Inferred '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.12.2.3/src/Database/Relational/PureUTF8.hs0000644000000000000000000000224113633172100021716 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Database.Relational.PureUTF8 -- Copyright : 2013-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines instances to lift from haskell UTF8 byte-sequence -- to query internal record values. -- This module is not defaultly imported to be selectable instance of byte-sequences. module Database.Relational.PureUTF8 () where import Control.Applicative (pure) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import qualified Database.Relational.Internal.Literal as Lit import Database.Relational.ProjectableClass (LiteralSQL (..)) -- | Constant SQL terms of 'ByteString'. instance LiteralSQL ByteString where showLiteral' = pure . Lit.stringExpr . T.unpack . T.decodeUtf8 -- | Constant SQL terms of 'LB.ByteString'. instance LiteralSQL LB.ByteString where showLiteral' = pure . Lit.stringExpr . LT.unpack . LT.decodeUtf8 relational-query-0.12.2.3/src/Database/Relational/Context.hs0000644000000000000000000000063313633172100021763 0ustar0000000000000000-- | -- Module : Database.Relational.Context -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module re-export query context tag types. module Database.Relational.Context ( module Database.Relational.Internal.ContextType ) where import Database.Relational.Internal.ContextType relational-query-0.12.2.3/src/Database/Relational/Scalar.hs0000644000000000000000000000152213633172100021542 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Scalar -- Copyright : 2013-2017 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.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.12.2.3/src/Database/Relational/Table.hs0000644000000000000000000000464513633172100021375 0ustar0000000000000000-- | -- Module : Database.Relational.Table -- Copyright : 2013-2019 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.Table ( -- * Phantom typed table type Table, untype, name, shortName, width, columns, index, table, toMaybe, recordWidth, toSubQuery, -- * Table existence inference TableDerivable (..) ) where import Data.Array (listArray) import Database.Record.Persistable (PersistableWidth, PersistableRecordWidth, unsafePersistableRecordWidth) import Database.Relational.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!)) import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) import Database.Relational.SqlSyntax (SubQuery) import qualified Database.Relational.SqlSyntax as Syntax -- | Phantom typed table type newtype Table r = Table Untyped instance Show (Table r) where show t = unwords ["Table", show $ name t, show . map showStringSQL $ columns t] -- | 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 -> [StringSQL] columns = columns' . untype -- | Column name string in SQL specified by index index :: Table r -> Int -- ^ Column index -> StringSQL -- ^ 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 stringSQL f -- | 'SubQuery' from 'Table'. toSubQuery :: Table r -- ^ Typed 'Table' metadata -> SubQuery -- ^ Result 'SubQuery' toSubQuery = Syntax.Table . untype -- | Inference rule of 'Table' existence. class PersistableWidth r => TableDerivable r where derivedTable :: Table r -- | PersistableRecordWidth of table recordWidth :: Table r -> PersistableRecordWidth r recordWidth = unsafePersistableRecordWidth . width relational-query-0.12.2.3/src/Database/Relational/Set.hs0000644000000000000000000001764013633172100021100 0ustar0000000000000000-- | -- Module : Database.Relational.Set -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines set operations on monadic Relation operations. module Database.Relational.Set ( -- * 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 Data.Functor.ProductIsomorphic ((|$|), (|*|)) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Duplication (Distinct, All), SubQuery, Predicate, Record, ) import qualified Database.Relational.SqlSyntax as Syntax import Database.Relational.Monad.BaseType (Relation, unsafeTypeRelation, untypeRelation, ) import Database.Relational.Monad.Class (MonadQuery (query', queryMaybe'), on) import Database.Relational.Monad.Simple (QuerySimple) import Database.Relational.Projectable (PlaceHolders) import Database.Relational.Relation (relation', relation, query, queryMaybe, ) -- | Restriction predicate function type for direct style join operator, -- used on predicates of direct join style as follows. -- -- @ -- do xy <- query $ -- relX `inner` relY `on'` [ \x y -> ... ] -- this lambda form has JoinRestriction type -- ... -- @ type JoinRestriction a b = Record Flat a -> Record Flat b -> Predicate Flat -- | Basic direct join operation with place-holder parameters. join' :: (qa -> QuerySimple (PlaceHolders pa, Record Flat a)) -> (qb -> QuerySimple (PlaceHolders pb, Record 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 |*| ph1, (,) |$| pj0 |*| 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 (Record Flat a)) -> (qb -> QuerySimple (Record 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 |*| 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 $ Syntax.union Distinct -- | Union of two relations. Not distinct. unionAll :: Relation () a -> Relation () a -> Relation () a unionAll = liftAppend $ Syntax.union All -- | Subtraction of two relations. except :: Relation () a -> Relation () a -> Relation () a except = liftAppend $ Syntax.except Distinct -- | Subtraction of two relations. Not distinct. exceptAll :: Relation () a -> Relation () a -> Relation () a exceptAll = liftAppend $ Syntax.except All -- | Intersection of two relations. intersect :: Relation () a -> Relation () a -> Relation () a intersect = liftAppend $ Syntax.intersect Distinct -- | Intersection of two relations. Not distinct. intersectAll :: Relation () a -> Relation () a -> Relation () a intersectAll = liftAppend $ Syntax.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' $ Syntax.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' $ Syntax.union All -- | Subtraction of two relations with place-holder parameters. except' :: Relation p a -> Relation q a -> Relation (p, q) a except' = liftAppend' $ Syntax.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' $ Syntax.except All -- | Intersection of two relations with place-holder parameters. intersect' :: Relation p a -> Relation q a -> Relation (p, q) a intersect' = liftAppend' $ Syntax.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' $ Syntax.intersect All infixl 7 `union`, `except`, `unionAll`, `exceptAll` infixl 8 `intersect`, `intersectAll` infixl 7 `union'`, `except'`, `unionAll'`, `exceptAll'` infixl 8 `intersect'`, `intersectAll'` relational-query-0.12.2.3/src/Database/Relational/Pi.hs0000644000000000000000000000122413633172100020704 0ustar0000000000000000-- | -- Module : Database.Relational.Pi -- Copyright : 2013-2019 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.Pi ( -- * Projection path Pi, (<.>), (), (), id', -- * Low-level API expandIndexes', expandIndexes, ) where import qualified Control.Category as Category import Database.Relational.Pi.Unsafe (Pi, (<.>), (), (), expandIndexes', expandIndexes) -- | Identity projection path. id' :: Pi a a id' = Category.id relational-query-0.12.2.3/src/Database/Relational/OverloadedProjection.hs0000644000000000000000000000352713633172100024465 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 800 -- | -- Module : Database.Relational.OverloadedProjection -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides interfaces of overloaded projections. module Database.Relational.OverloadedProjection ( HasProjection (..), ) where import GHC.OverloadedLabels (IsLabel(..)) import GHC.TypeLits (Symbol) import Database.Record (PersistableWidth) import Database.Relational.SqlSyntax (PI) import Database.Relational.Pi (Pi) import Database.Relational.Projectable ((!)) data PiLabel (l :: Symbol) = GetPi -- | Projection interface to implement Pi with row polymorphism. class HasProjection l a b | l a -> b where projection :: PiLabel l -> Pi a b #if __GLASGOW_HASKELL__ >= 802 -- | Derive 'IsLabel' instance from 'HasProjection'. instance HasProjection l a b => IsLabel l (Pi a b) where fromLabel = projection (GetPi :: PiLabel l) -- | Derive 'PI' label. instance (PersistableWidth a, HasProjection l a b) => IsLabel l (PI c a b) where fromLabel = (! projection (GetPi :: PiLabel l)) #else -- | Derive 'IsLabel' instance from 'HasProjection'. instance HasProjection l a b => IsLabel l (Pi a b) where fromLabel _ = projection (GetPi :: PiLabel l) -- | Derive 'PI' label. instance (PersistableWidth a, HasProjection l a b) => IsLabel l (PI c a b) where fromLabel _ = (! projection (GetPi :: PiLabel l)) #endif #else module Database.Relational.OverloadedProjection () where #endif relational-query-0.12.2.3/src/Database/Relational/Projectable.hs0000644000000000000000000005717213633172100022603 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Projectable -- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines operators on various projected records. module Database.Relational.Projectable ( -- * Projectable from SQL strings SqlContext (unsafeProjectSqlTerms), unsafeProjectSql', unsafeProjectSql, -- * Records of values value, valueTrue, valueFalse, values, nothing, -- * Placeholders PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders, pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH, -- * Projectable into SQL strings 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, (><), -- * 'Maybe' type projecitoins ProjectableMaybe (just, flattenMaybe), -- * Projection for nested 'Maybe's ProjectableFlattenMaybe (flatten), flattenPiMaybe, -- * Get narrower records (!), (?), (??), (?!), (?!?), (!??), -- * Aggregate functions unsafeAggregateOp, count, sum', sumMaybe, avg, avgMaybe, max', maxMaybe, min', minMaybe, every, any', some', ) where import Prelude hiding (pi) import Data.String (IsString) import Data.Functor.ProductIsomorphic ((|$|), ProductIsoApplicative, pureP, (|*|), ) import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth, HasColumnConstraint, NotNull) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Internal.ContextType (Flat, Exists, OverWindow) import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) import Database.Relational.SqlSyntax (Record, Predicate) import qualified Database.Relational.SqlSyntax as Syntax import Database.Relational.Pure () import Database.Relational.TupleInstances () import Database.Relational.Pi (Pi) import Database.Relational.ProjectableClass (LiteralSQL, showLiteral, ) import Database.Relational.Record (RecordList) import qualified Database.Relational.Record as Record import Database.Relational.Projectable.Unsafe (SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..)) import Database.Relational.Projectable.Instances () -- | Unsafely Project single SQL term. unsafeProjectSql' :: SqlContext c => StringSQL -> Record c t unsafeProjectSql' = unsafeProjectSqlTerms . (:[]) -- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql'''. unsafeProjectSql :: SqlContext c => String -> Record c t unsafeProjectSql = unsafeProjectSql' . stringSQL -- | Record with polymorphic phantom type of SQL null value. Semantics of comparing is unsafe. nothing :: (OperatorContext c, SqlContext c, PersistableWidth a) => Record c (Maybe a) nothing = proxyWidth persistableWidth where proxyWidth :: SqlContext c => PersistableRecordWidth a -> Record c (Maybe a) proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL -- | Generate record with polymorphic type of SQL constant values from Haskell value. value :: (LiteralSQL t, OperatorContext c) => t -> Record c t value = unsafeProjectSqlTerms . showLiteral -- | Record with polymorphic type of SQL true value. valueTrue :: OperatorContext c => Record c (Maybe Bool) valueTrue = just $ value True -- | Record with polymorphic type of SQL false value. valueFalse :: OperatorContext c => Record c (Maybe Bool) valueFalse = just $ value False -- | RecordList with polymorphic type of SQL set value from Haskell list. values :: (LiteralSQL t, OperatorContext c) => [t] -> RecordList (Record c) t values = Record.list . map value -- | Unsafely generate SQL expression term from record object. unsafeShowSql' :: Record c a -> StringSQL unsafeShowSql' = Record.unsafeStringSql -- | Unsafely generate SQL expression string from record object. -- String interface of 'unsafeShowSql''. unsafeShowSql :: Record c a -- ^ Source record object -> String -- ^ Result SQL expression string. unsafeShowSql = showStringSQL . unsafeShowSql' -- | Binary operator type for SQL String. type SqlBinOp = Keyword -> Keyword -> Keyword -- | Unsafely make unary operator for records from SQL keyword. unsafeUniOp :: SqlContext c2 => (Keyword -> Keyword) -> Record c1 a -> Record c2 b unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql' unsafeFlatUniOp :: SqlContext c => Keyword -> Record c a -> Record c b unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw) -- | Unsafely make binary operator for records from string binary operator. unsafeBinOp :: SqlContext k => SqlBinOp -> Record k a -> Record k b -> Record k c unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $ op (unsafeShowSql' a) (unsafeShowSql' b) -- | Unsafely make binary operator to compare records from string binary operator. compareBinOp :: SqlContext c => SqlBinOp -> Record c a -> Record c a -> Record c (Maybe Bool) compareBinOp = unsafeBinOp -- | Unsafely make numrical binary operator for records from string binary operator. monoBinOp :: SqlContext c => SqlBinOp -> Record c a -> Record c a -> Record c a monoBinOp = unsafeBinOp -- | Compare operator corresponding SQL /=/ . (.=.) :: OperatorContext c => Record c ft -> Record c ft -> Record c (Maybe Bool) (.=.) = compareBinOp (SQL..=.) -- | Compare operator corresponding SQL / Record c ft -> Record c ft -> Record c (Maybe Bool) (.<.) = compareBinOp (SQL..<.) -- | Compare operator corresponding SQL /<=/ . (.<=.) :: OperatorContext c => Record c ft -> Record c ft -> Record c (Maybe Bool) (.<=.) = compareBinOp (SQL..<=.) -- | Compare operator corresponding SQL />/ . (.>.) :: OperatorContext c => Record c ft -> Record c ft -> Record c (Maybe Bool) (.>.) = compareBinOp (SQL..>.) -- | Compare operator corresponding SQL />=/ . (.>=.) :: OperatorContext c => Record c ft -> Record c ft -> Record c (Maybe Bool) (.>=.) = compareBinOp (SQL..>=.) -- | Compare operator corresponding SQL /<>/ . (.<>.) :: OperatorContext c => Record c ft -> Record c ft -> Record c (Maybe Bool) (.<>.) = compareBinOp (SQL..<>.) -- | Logical operator corresponding SQL /AND/ . and' :: OperatorContext c => Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool) and' = monoBinOp SQL.and -- | Logical operator corresponding SQL /OR/ . or' :: OperatorContext c => Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool) or' = monoBinOp SQL.or -- | Logical operator corresponding SQL /NOT/ . not' :: OperatorContext c => Record c (Maybe Bool) -> Record c (Maybe Bool) not' = unsafeFlatUniOp SQL.NOT -- | Logical operator corresponding SQL /EXISTS/ . exists :: OperatorContext c => RecordList (Record Exists) r -> Record c (Maybe Bool) exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS . Record.unsafeStringSqlList unsafeShowSql' -- | Concatinate operator corresponding SQL /||/ . (.||.) :: OperatorContext c => Record c a -> Record c a -> Record c a (.||.) = unsafeBinOp (SQL..||.) -- | Concatinate operator corresponding SQL /||/ . Maybe type version. (?||?) :: (OperatorContext c, IsString a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) (?||?) = unsafeBinOp (SQL..||.) unsafeLike :: OperatorContext c => Record c a -> Record c b -> Record c (Maybe Bool) unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE) -- | String-compare operator corresponding SQL /LIKE/ . like' :: (OperatorContext c, IsString a) => Record c a -> Record c a -> Record c (Maybe Bool) x `like'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . likeMaybe' :: (OperatorContext c, IsString a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe Bool) x `likeMaybe'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . like :: (OperatorContext c, IsString a, LiteralSQL a) => Record c a -> a -> Record c (Maybe Bool) x `like` a = x `like'` value a -- | String-compare operator corresponding SQL /LIKE/ . Maybe type version. likeMaybe :: (OperatorContext c, IsString a, LiteralSQL a) => Record c (Maybe a) -> a -> Record c (Maybe Bool) x `likeMaybe` a = x `unsafeLike` value a -- | Unsafely make number binary operator for records from SQL operator string. monoBinOp' :: SqlContext c => Keyword -> Record c a -> Record c a -> Record c a monoBinOp' = monoBinOp . SQL.defineBinOp -- | Number operator corresponding SQL /+/ . (.+.) :: (OperatorContext c, Num a) => Record c a -> Record c a -> Record c a (.+.) = monoBinOp' "+" -- | Number operator corresponding SQL /-/ . (.-.) :: (OperatorContext c, Num a) => Record c a -> Record c a -> Record c a (.-.) = monoBinOp' "-" -- | Number operator corresponding SQL /// . (./.) :: (OperatorContext c, Num a) => Record c a -> Record c a -> Record c a (./.) = monoBinOp' "/" -- | Number operator corresponding SQL /*/ . (.*.) :: (OperatorContext c, Num a) => Record c a -> Record c a -> Record c a (.*.) = monoBinOp' "*" -- | Number negate uni-operator corresponding SQL /-/. negate' :: (OperatorContext c, Num a) => Record c a -> Record c a negate' = unsafeFlatUniOp $ SQL.word "-" unsafeCastProjectable :: SqlContext c => Record c a -> Record c b unsafeCastProjectable = Syntax.record . Syntax.untypeRecord -- | Number fromIntegral uni-operator. fromIntegral' :: (SqlContext c, Integral a, Num b) => Record c a -> Record c b fromIntegral' = unsafeCastProjectable -- | Unsafely show number into string-like type in records. showNum :: (SqlContext c, Num a, IsString b) => Record c a -> Record c b showNum = unsafeCastProjectable -- | Number operator corresponding SQL /+/ . (?+?) :: (OperatorContext c, Num a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) (?+?) = monoBinOp' "+" -- | Number operator corresponding SQL /-/ . (?-?) :: (OperatorContext c, Num a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) (?-?) = monoBinOp' "-" -- | Number operator corresponding SQL /// . (?/?) :: (OperatorContext c, Num a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) (?/?) = monoBinOp' "/" -- | Number operator corresponding SQL /*/ . (?*?) :: (OperatorContext c, Num a) => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) (?*?) = monoBinOp' "*" -- | Number negate uni-operator corresponding SQL /-/. negateMaybe :: (OperatorContext c, Num a) => Record c (Maybe a) -> Record c (Maybe a) negateMaybe = unsafeFlatUniOp $ SQL.word "-" -- | Number fromIntegral uni-operator. fromIntegralMaybe :: (SqlContext c, Integral a, Num b) => Record c (Maybe a) -> Record c (Maybe b) fromIntegralMaybe = unsafeCastProjectable -- | Unsafely show number into string-like type in records. showNumMaybe :: (SqlContext c, Num a, IsString b) => Record c (Maybe a) -> Record c (Maybe b) showNumMaybe = unsafeCastProjectable -- | Search case operator correnponding SQL search /CASE/. -- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ caseSearch :: OperatorContext c => [(Predicate c, Record c a)] -- ^ Each when clauses -> Record c a -- ^ Else result record -> Record c a -- ^ Result record caseSearch = Syntax.caseSearch -- | Same as 'caseSearch', but you can write like `casesOrElse` . casesOrElse :: OperatorContext c => [(Predicate c, Record c a)] -- ^ Each when clauses -> Record c a -- ^ Else result record -> Record c a -- ^ Result record casesOrElse = caseSearch -- | Null default version of 'caseSearch'. caseSearchMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, PersistableWidth a) => [(Predicate c, Record c (Maybe a))] -- ^ Each when clauses -> Record c (Maybe a) -- ^ Result record caseSearchMaybe cs = caseSearch cs nothing -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ case' :: OperatorContext c => Record c a -- ^ Record value to match -> [(Record c a, Record c b)] -- ^ Each when clauses -> Record c b -- ^ Else result record -> Record c b -- ^ Result record case' = Syntax.case' -- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` . casesOrElse' :: OperatorContext c => (Record c a, [(Record c a, Record c b)]) -- ^ Record value to match and each when clauses list -> Record c b -- ^ Else result record -> Record c b -- ^ Result record casesOrElse' = uncurry case' -- | Null default version of 'case''. caseMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, PersistableWidth b) => Record c a -- ^ Record value to match -> [(Record c a, Record c (Maybe b))] -- ^ Each when clauses -> Record c (Maybe b) -- ^ Result record caseMaybe v cs = case' v cs nothing -- | Binary operator corresponding SQL /IN/ . in' :: OperatorContext c => Record c t -> RecordList (Record c) t -> Record c (Maybe Bool) in' a lp = unsafeProjectSql' . SQL.paren $ SQL.in' (unsafeShowSql' a) (Record.unsafeStringSqlList unsafeShowSql' lp) -- | Operator corresponding SQL /IS NULL/ , and extended against record types. isNothing :: (OperatorContext c, HasColumnConstraint NotNull r) => Record c (Maybe r) -> Predicate c isNothing mr = unsafeProjectSql' $ SQL.paren $ (SQL.defineBinOp SQL.IS) (Record.unsafeStringSqlNotNullMaybe mr) SQL.NULL -- | Operator corresponding SQL /NOT (... IS NULL)/ , and extended against record type. isJust :: (OperatorContext c, HasColumnConstraint NotNull r) => Record c (Maybe r) -> Predicate c isJust = not' . isNothing -- | Operator from maybe type using record extended 'isNull'. fromMaybe :: (OperatorContext c, HasColumnConstraint NotNull r) => Record c r -> Record c (Maybe r) -> Record c r fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p unsafeUniTermFunction :: SqlContext c => Keyword -> Record c t unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()") -- | /RANK()/ term. rank :: Integral a => Record OverWindow a rank = unsafeUniTermFunction SQL.RANK -- | /DENSE_RANK()/ term. denseRank :: Integral a => Record OverWindow a denseRank = unsafeUniTermFunction SQL.DENSE_RANK -- | /ROW_NUMBER()/ term. rowNumber :: Integral a => Record OverWindow a rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER -- | /PERCENT_RANK()/ term. percentRank :: Record OverWindow Double percentRank = unsafeUniTermFunction SQL.PERCENT_RANK -- | /CUME_DIST()/ term. cumeDist :: Record OverWindow Double cumeDist = unsafeUniTermFunction SQL.CUME_DIST -- | 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 = pureP () -- | No placeholder semantics. Same as `unitPlaceHolder` unitPH :: PlaceHolders () unitPH = pureP () -- | Unsafely cast placeholder parameter type. unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b unsafeCastPlaceHolders PlaceHolders = PlaceHolders -- | Provide scoped placeholder from width and return its parameter object. pwPlaceholder :: SqlContext c => PersistableRecordWidth a -> (Record c a -> b) -> (PlaceHolders a, b) pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw) where projectPlaceHolder :: SqlContext c => PersistableRecordWidth a -> Record c a projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth -- | Provide scoped placeholder and return its parameter object. placeholder' :: (PersistableWidth t, SqlContext c) => (Record c t -> a) -> (PlaceHolders t, a) placeholder' = pwPlaceholder persistableWidth -- | Provide scoped placeholder and return its parameter object. Monadic version. placeholder :: (PersistableWidth t, SqlContext c, Monad m) => (Record c t -> m a) -> m (PlaceHolders t, a) placeholder f = do let (ph, ma) = placeholder' f a <- ma return (ph, a) -- | Zipping projections. projectZip :: ProductIsoApplicative p => p a -> p b -> p (a, b) projectZip pa pb = (,) |$| pa |*| pb -- | Binary operator the same as 'projectZip'. (><) :: ProductIsoApplicative p => p a -> p b -> p (a, b) (><) = projectZip -- | Interface to control 'Maybe' of phantom type in records. class ProjectableMaybe p where -- | Cast record phantom type into 'Maybe'. just :: p a -> p (Maybe a) -- | Compose nested 'Maybe' phantom type on record. 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 record type 'Record'. instance ProjectableMaybe (Record c) where just = Record.just flattenMaybe = Record.flattenMaybe -- | Unsafely make aggregation uni-operator from SQL keyword. unsafeAggregateOp :: (AggregatedContext ac, SqlContext ac) => SQL.Keyword -> Record Flat a -> Record ac b unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren) -- | Aggregation function COUNT. count :: (Integral b, AggregatedContext ac, SqlContext ac) => Record Flat a -> Record ac b count = unsafeAggregateOp SQL.COUNT -- | Aggregation function SUM. sumMaybe :: (Num a, AggregatedContext ac, SqlContext ac) => Record Flat (Maybe a) -> Record ac (Maybe a) sumMaybe = unsafeAggregateOp SQL.SUM -- | Aggregation function SUM. sum' :: (Num a, AggregatedContext ac, SqlContext ac) => Record Flat a -> Record ac (Maybe a) sum' = sumMaybe . Record.just -- | Aggregation function AVG. avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac) => Record Flat (Maybe a) -> Record ac (Maybe b) avgMaybe = unsafeAggregateOp SQL.AVG -- | Aggregation function AVG. avg :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac) => Record Flat a -> Record ac (Maybe b) avg = avgMaybe . Record.just -- | Aggregation function MAX. maxMaybe :: (Ord a, AggregatedContext ac, SqlContext ac) => Record Flat (Maybe a) -> Record ac (Maybe a) maxMaybe = unsafeAggregateOp SQL.MAX -- | Aggregation function MAX. max' :: (Ord a, AggregatedContext ac, SqlContext ac) => Record Flat a -> Record ac (Maybe a) max' = maxMaybe . Record.just -- | Aggregation function MIN. minMaybe :: (Ord a, AggregatedContext ac, SqlContext ac) => Record Flat (Maybe a) -> Record ac (Maybe a) minMaybe = unsafeAggregateOp SQL.MIN -- | Aggregation function MIN. min' :: (Ord a, AggregatedContext ac, SqlContext ac) => Record Flat a -> Record ac (Maybe a) min' = minMaybe . Record.just -- | Aggregation function EVERY. every :: (AggregatedContext ac, SqlContext ac) => Predicate Flat -> Record ac (Maybe Bool) every = unsafeAggregateOp SQL.EVERY -- | Aggregation function ANY. any' :: (AggregatedContext ac, SqlContext ac) => Predicate Flat -> Record ac (Maybe Bool) any' = unsafeAggregateOp SQL.ANY -- | Aggregation function SOME. some' :: (AggregatedContext ac, SqlContext ac) => Predicate Flat -> Record ac (Maybe Bool) some' = unsafeAggregateOp SQL.SOME -- | Get narrower record along with projection path. (!) :: PersistableWidth a => Record c a -- ^ Source 'Record' -> Pi a b -- ^ Record path -> Record c b -- ^ Narrower projected object (!) = Record.pi -- | Get narrower record along with projection path -- 'Maybe' phantom functor is 'map'-ed. (?!) :: PersistableWidth a => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type -> Pi a b -- ^ Record path -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result (?!) = Record.piMaybe -- | Get narrower record along with projection path -- and project into result record type. -- Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed. (?!?) :: PersistableWidth a => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type -> Pi a (Maybe b) -- ^ Record path. 'Maybe' type leaf -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result (?!?) = Record.piMaybe' -- | Interface to compose phantom 'Maybe' nested type. class ProjectableFlattenMaybe a b where flatten :: ProjectableMaybe p => p a -> p b -- | Compose 'Maybe' type in record 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 record with flatten leaf phantom Maybe types along with projection path. flattenPiMaybe :: (PersistableWidth a, ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Record cont c -- ^ Narrower 'Record'. Flatten 'Maybe' phantom type flattenPiMaybe p = flatten . Record.piMaybe p -- | Get narrower record with flatten leaf phantom Maybe types along with projection path. (!??) :: (PersistableWidth a, ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Record cont c -- ^ Narrower flatten and projected object. (!??) = flattenPiMaybe -- | Same as '(?!)'. Use this operator like '(? #foo) mayX'. (?) :: PersistableWidth a => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type -> Pi a b -- ^ Record path -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result (?) = (?!) -- | Same as '(?!?)'. Use this operator like '(?? #foo) mayX'. (??) :: PersistableWidth a => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type -> Pi a (Maybe b) -- ^ Record path. 'Maybe' type leaf -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result (??) = (?!?) infixl 8 !, ?, ??, ?!, ?!?, !?? infixl 7 .*., ./., ?*?, ?/? infixl 6 .+., .-., ?+?, ?-? infixl 5 .||., ?||? infix 4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'` infixr 3 `and'` infixr 2 `or'` infixl 1 >< relational-query-0.12.2.3/src/Database/Relational/Arrow.hs0000644000000000000000000005075613633172100021444 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Arrow -- Copyright : 2015-2019 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 projected records may cause to break -- the result query. -- It is possible to controls injection of previous local projected records -- 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.Arrow ( module Database.Relational, 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', orderBy, asc, desc, partitionBy, over, assign, update', update, updateNoPH, updateAllColumn', updateAllColumn, updateAllColumnNoPH, insertValue', insertValue, insertValueNoPH, delete', delete, deleteNoPH, QueryA, QuerySimple, QueryAggregate, QueryUnique, AggregatingSet, AggregatingSetList, AggregatingPowerSet, Orderings, Window, Assignings, AssignStatement, Register, RestrictedStatement, -- * Deprecated derivedUpdate', derivedUpdate, derivedInsertValue', derivedInsertValue, derivedDelete', derivedDelete, ) where import Control.Category (Category) import Control.Arrow (Arrow, Kleisli (..)) import Database.Record import Database.Relational 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', orderBy, asc, desc, partitionBy, over, update', update, updateNoPH, derivedUpdate', derivedUpdate, updateAllColumn', updateAllColumn, updateAllColumnNoPH, insertValue', insertValue, insertValueNoPH, derivedInsertValue', derivedInsertValue, delete', delete, deleteNoPH, derivedDelete', derivedDelete, QuerySimple, QueryAggregate, QueryUnique, Orderings, Window, Register) import qualified Database.Relational as Monadic import qualified Database.Relational.Monad.Trans.Aggregating as Monadic import qualified Database.Relational.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 = QueryA (Monadic.Assignings r Restrict) (Record Flat r) a -- | Arrow type corresponding to 'Monadic.Register' type Register r a = QueryA (Monadic.Register r) () a -- | Arrow type corresponding to 'Monadic.RestrictedStatement' type RestrictedStatement r a = QueryA Monadic.Restrict (Record 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 projected records. query :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> QueryA m () (Record Flat r) query r = queryA $ \() -> Monadic.query r -- | Same as 'Monadic.queryMaybe'. Arrow version. -- The result arrow is not injected by any local projected records. queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> QueryA m () (Record Flat (Maybe r)) queryMaybe r = queryA $ \() -> Monadic.queryMaybe r -- | Same as 'Monadic.query''. Arrow version. -- The result arrow is not injected by any local projected records. query' :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation p r -> QueryA m () (PlaceHolders p, Record Flat r) query' r = queryA $ \() -> Monadic.query' r -- | Same as 'Monadic.queryMaybe''. Arrow version. -- The result arrow is not injected by any local projected records. queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation p r -> QueryA m () (PlaceHolders p, Record Flat (Maybe r)) queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r unsafeQueryList :: MonadQualify ConfigureQuery m => (a -> Relation () r) -> QueryA m a (RecordList (Record c) r) unsafeQueryList rf = queryA $ Monadic.queryList . rf unsafeQueryList' :: MonadQualify ConfigureQuery m => (a -> Relation p r) -> QueryA m a (PlaceHolders p, RecordList (Record c) r) unsafeQueryList' rf = queryA $ Monadic.queryList' . rf -- | Same as 'Monadic.queryList'. Arrow version. -- The result arrow is designed to be injected by local projected records. queryList :: MonadQualify ConfigureQuery m => (Record c a -> Relation () r) -> QueryA m (Record c a) (RecordList (Record c) r) queryList = unsafeQueryList -- | Same as 'Monadic.queryList''. Arrow version. -- The result arrow is designed to be injected by local projected records. queryList' :: MonadQualify ConfigureQuery m => (Record c a -> Relation p r) -> QueryA m (Record c a) (PlaceHolders p, RecordList (Record 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 projected records. queryExists :: MonadQualify ConfigureQuery m => (Record c a -> Relation () r) -> QueryA m (Record c a) (RecordList (Record 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 projected records. queryExists' :: MonadQualify ConfigureQuery m => (Record c a -> Relation p r) -> QueryA m (Record c a) (PlaceHolders p, RecordList (Record Exists) r) queryExists' = unsafeQueryList' -- | Same as 'Monadic.queryList'. Arrow version. -- Useful for no reference cases to local projected records. queryListU :: MonadQualify ConfigureQuery m => Relation () r -> QueryA m () (RecordList (Record c) r) queryListU r = unsafeQueryList $ \() -> r -- | Same as 'Monadic.queryList''. Arrow version. -- Useful for no reference cases to local projected records. queryListU' :: MonadQualify ConfigureQuery m => Relation p r -> QueryA m () (PlaceHolders p, RecordList (Record c) r) queryListU' r = unsafeQueryList' $ \() -> r unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (a -> UniqueRelation () c r) -> QueryA m a (Record 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, Record 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 projected record. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (Record c a -> UniqueRelation () c r) -> QueryA m (Record c a) (Record c (Maybe r)) queryScalar = unsafeQueryScalar -- | Same as 'Monadic.queryScalar''. Arrow version. -- The result arrow is designed to be injected by any local projected record. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (Record c a -> UniqueRelation p c r) -> QueryA m (Record c a) (PlaceHolders p, Record c (Maybe r)) queryScalar' = unsafeQueryScalar' -- | Same as 'Monadic.queryScalar'. Arrow version. -- Useful for no reference cases to local projected records. queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> QueryA m () (Record c (Maybe r)) queryScalarU r = unsafeQueryScalar $ \() -> r -- | Same as 'Monadic.queryScalar''. Arrow version. -- Useful for no reference cases to local projected records. queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation p c r -> QueryA m () (PlaceHolders p, Record c (Maybe r)) queryScalarU' r = unsafeQueryScalar' $ \() -> r -- | Same as 'Monadic.uniqueQuery''. Arrow version. -- The result arrow is not injected by local projected records. uniqueQuery' :: UniqueRelation p c r -> QueryA Monadic.QueryUnique () (PlaceHolders p, Record c r) uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r -- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version. -- The result arrow is not injected by local projected records. uniqueQueryMaybe' :: UniqueRelation p c r -> QueryA Monadic.QueryUnique () (PlaceHolders p, Record 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-records. on :: MonadQuery m => QueryA m (Predicate Flat) () on = queryA Monadic.on -- | Same as 'Monadic.wheres'. Arrow version. -- The result arrow is designed to be injected by local conditional flat-records. wheres :: MonadRestrict Flat m => QueryA m (Predicate Flat) () wheres = queryA Monadic.wheres -- | Same as 'Monadic.having'. Arrow version. -- The result arrow is designed to be injected by local conditional aggregated-records. having :: MonadRestrict Aggregated m => QueryA m (Predicate Aggregated) () having = queryA Monadic.having -- | Same as 'Monadic.groupBy'. Arrow version. -- The result arrow is designed to be injected by local flat-records. groupBy :: MonadAggregate m => QueryA m (Record Flat r) (Record 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, SqlContext c, Monad m) => QueryA m (QueryA m (Record c 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 () (Record 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, Record Flat r) -> Relation p r relation' = runAofM Monadic.relation' -- | Same as 'Monadic.aggregateRelation'. -- Finalize query-building arrow instead of query-building monad. aggregateRelation :: QueryAggregate () (Record 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, Record 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, Record 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 (Record Aggregated r)) (Record Aggregated r) groupBy' = queryA Monadic.groupBy' -- | Same as 'Monadic.key'. -- This arrow is designed to be injected by local flat-records. key :: AggregatingSet (Record Flat r) (Record 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-records. bkey :: AggregatingPowerSet (Record Flat r) (Record 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 projected records. orderBy' :: Monad m => Order -> Nulls -> Orderings c m (Record c t) () orderBy' o n = queryA $ \p -> Monadic.orderBy' p o n -- | Same as 'Monadic.orderBy'. -- The result arrow is designed to be injected by local projected records. orderBy :: Monad m => Order -> Orderings c m (Record c t) () orderBy o = queryA (`Monadic.orderBy` o) -- | Same as 'Monadic.asc'. -- The result arrow is designed to be injected by local projected records. asc :: Monad m => Orderings c m (Record c t) () asc = queryA Monadic.asc -- | Same as 'Monadic.desc'. -- The result arrow is designed to be injected by local projected records. desc :: Monad m => Orderings c m (Record c t) () desc = queryA Monadic.desc -- | Same as 'Monadic.partitionBy'. -- The result arrow is designed to be injected by local projected records. partitionBy :: Window c (Record c r) () partitionBy = queryA Monadic.partitionBy -- | Same as 'Monadic.over'. -- Make record of window function result using built 'Window' arrow. over :: SqlContext c => Record OverWindow a -> Window c () () -> Record c a over po = runAofM $ Monadic.over po infix 8 `over` -- | Make 'Monadic.AssignTarget' into arrow which is designed to be -- injected by assignees of local projected record. assign :: Monad m => Monadic.AssignTarget r v -> Assignings r m (Record Flat v) () assign t = queryA (`Monadic.assignTo` t) -- | Same as 'Monadic.update''. -- Make 'Update' from assigning statement arrow using configuration. update' :: TableDerivable r => Config -> QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p update' config = Monadic.update' config . runQueryA -- | Same as 'Monadic.update'. -- Make 'Update' from assigning statement arrow. update :: TableDerivable r => QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p update = Monadic.update . runQueryA -- | Same as 'Monadic.updateNoPH'. -- Make 'Update' from assigning statement arrow. updateNoPH :: TableDerivable r => QueryA (Monadic.Assignings r Restrict) (Record Flat r) () -> Update () updateNoPH = Monadic.updateNoPH . runQueryA -- | Same as 'Monadic.updateAllColumn''. -- Make 'Update' from restrected statement arrow. updateAllColumn' :: (PersistableWidth r, TableDerivable r) => Config -> QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Update (r, p) updateAllColumn' config = Monadic.updateAllColumn' config . runQueryA -- | Same as 'Monadic.updateAllColumn'. -- Make 'Update' from restrected statement arrow. updateAllColumn :: (PersistableWidth r, TableDerivable r) => QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Update (r, p) updateAllColumn = Monadic.updateAllColumn . runQueryA -- | Same as 'Monadic.updateAllColumnNoPH'. -- Make 'Update' from restrected statement arrow. updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r) => QueryA Monadic.Restrict (Record Flat r) () -> Update r updateAllColumnNoPH = Monadic.updateAllColumnNoPH . runQueryA -- | Same as 'Monadic.insertValue''. -- Make 'Insert' from register arrow using configuration. insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p insertValue' config = Monadic.insertValue' config . ($ ()) . runQueryA -- | Same as 'Monadic.insertValue'. -- Make 'Insert' from register arrow. insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p insertValue = Monadic.insertValue . ($ ()) . runQueryA -- | Same as 'Monadic.insertValueNoPH'. -- Make 'Insert' from register arrow. insertValueNoPH :: TableDerivable r => Register r () -> Insert () insertValueNoPH = Monadic.insertValueNoPH . ($ ()) . runQueryA -- | Same as 'Monadic.delete''. -- Make 'Update' from restrict statement arrow using configuration. delete' :: TableDerivable r => Config -> QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p delete' config = Monadic.delete' config . runQueryA -- | Same as 'Monadic.delete'. -- Make 'Update' from restrict statement arrow. delete :: TableDerivable r => QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p delete = Monadic.delete . runQueryA -- | Same as 'Monadic.deleteNoPH'. -- Make 'Update' from restrict statement arrow. deleteNoPH :: TableDerivable r => QueryA Monadic.Restrict (Record Flat r) () -> Delete () deleteNoPH = Monadic.deleteNoPH . runQueryA {-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-} -- | Same as 'Monadic.update''. -- Make 'Update' from assigning statement arrow using configuration. derivedUpdate' :: TableDerivable r => Config -> QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p derivedUpdate' = update' {-# DEPRECATED derivedUpdate "use `update` instead of this." #-} -- | Deprecated. derivedUpdate :: TableDerivable r => QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p derivedUpdate = update {-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-} -- | Deprecated. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p derivedInsertValue' = insertValue' {-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-} -- | Deprecated. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p derivedInsertValue = insertValue {-# DEPRECATED derivedDelete' "use `derivedDelete'` instead of this." #-} -- | Deprecated. derivedDelete' :: TableDerivable r => Config -> QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p derivedDelete' = delete' {-# DEPRECATED derivedDelete "use `derivedDelete` instead of this." #-} -- | Deprecated. derivedDelete :: TableDerivable r => QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p derivedDelete = delete relational-query-0.12.2.3/src/Database/Relational/SqlSyntax.hs0000644000000000000000000000156313633172100022310 0ustar0000000000000000-- | -- Module : Database.Relational.SqlSyntax -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module is integrated module of sql-syntax. module Database.Relational.SqlSyntax ( module Database.Relational.SqlSyntax.Types, module Database.Relational.SqlSyntax.Join, module Database.Relational.SqlSyntax.Aggregate, module Database.Relational.SqlSyntax.Query, module Database.Relational.SqlSyntax.Fold, module Database.Relational.SqlSyntax.Updates, ) where import Database.Relational.SqlSyntax.Types import Database.Relational.SqlSyntax.Join (growProduct, restrictProduct, ) import Database.Relational.SqlSyntax.Aggregate import Database.Relational.SqlSyntax.Query import Database.Relational.SqlSyntax.Fold import Database.Relational.SqlSyntax.Updates relational-query-0.12.2.3/src/Database/Relational/TupleInstances.hs0000644000000000000000000000215613633172100023302 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Database.Relational.TupleInstances -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines ProductConstructor instances and projection path objects of tuple types. module Database.Relational.TupleInstances where import Control.Applicative ((<$>)) import Database.Record (PersistableWidth) import Database.Relational.Pi (Pi) import Database.Relational.InternalTH.Base (defineTuplePi, defineTupleShowLiteralInstance,) $(concat <$> mapM defineTuplePi [2..7]) $(concat <$> mapM defineTupleShowLiteralInstance [2..7]) -- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics. -- | Projection path for fst of tuple. fst' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) a fst' = tuplePi2_0' -- | Projection path for snd of tuple. snd' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) b snd' = tuplePi2_1' relational-query-0.12.2.3/src/Database/Relational/Effect.hs0000644000000000000000000002562313633172100021541 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Effect -- Copyright : 2013-2019 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.Effect ( -- * Object to express simple restriction. Restriction, -- * Object to express update target columns and restriction. UpdateTarget, liftTargetAllColumn', -- * Object to express insert terget. InsertTarget, insertTarget', piRegister, -- * Generate SQL from restriction. deleteFromRestriction, updateFromUpdateTarget, sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList, -- * Deprecated restriction, restriction', updateTarget, updateTarget', liftTargetAllColumn, updateTargetAllColumn, updateTargetAllColumn', insertTarget, sqlWhereFromRestriction, sqlFromUpdateTarget, ) where import Control.Applicative ((<$>)) import Control.Monad (void) import Data.Monoid ((<>)) import Data.List (unfoldr) import Data.Functor.ProductIsomorphic (peRight) import Language.SQL.Keyword (Keyword(..)) import Database.Record.Persistable (PersistableWidth) import Database.Relational.Internal.Config (Config (chunksInsertSize, addModifyTableAliasAS), defaultConfig) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) import Database.Relational.SqlSyntax (Record, composeWhere, composeSets, composeChunkValuesWithColumns, composeValuesListWithColumns, Qualified, SubQuery, corrSubQueryTerm) import Database.Relational.Pi (Pi, id') import qualified Database.Relational.Pi.Unsafe as Pi import Database.Relational.Table (Table, TableDerivable, derivedTable) import qualified Database.Relational.Table as Table import qualified Database.Relational.Record as Record import Database.Relational.ProjectableClass (LiteralSQL) import Database.Relational.Projectable (PlaceHolders, unitPH, pwPlaceholder, placeholder, (><), value, ) import Database.Relational.Monad.BaseType (ConfigureQuery, qualifyQuery, askConfig) import Database.Relational.Monad.Class (MonadQualify (..)) import Database.Relational.Monad.Trans.Assigning (assignings, (<-#)) import Database.Relational.Monad.Restrict (Restrict) import qualified Database.Relational.Monad.Restrict as Restrict import Database.Relational.Monad.Assign (Assign) import qualified Database.Relational.Monad.Assign as Assign import Database.Relational.Monad.Register (Register) import qualified Database.Relational.Monad.Register as Register -- helper function for UPDATE and DELETE withQualified :: MonadQualify ConfigureQuery m => Table r -> (Record c r -> m a) -> m StringSQL withQualified tbl q = do let qualTandR :: MonadQualify ConfigureQuery m => Table r -> m (Qualified SubQuery, Record c r) qualTandR tbl_ = liftQualify $ do qq <- qualifyQuery $ Table.toSubQuery tbl_ return (qq, Record.unsafeFromQualifiedSubQuery qq {- qualified record expression -}) (qq, r) <- qualTandR tbl void $ q r -- placeholder info is not used addAS <- addModifyTableAliasAS <$> liftQualify askConfig return $ corrSubQueryTerm addAS qq {- qualified table -} -- | Restriction type with place-holder parameter 'p' and projected record type 'r'. type Restriction p r = Record Flat r -> Restrict (PlaceHolders p) -- | Deprecated. restriction :: (Record Flat r -> Restrict ()) -> Restriction () r restriction = ((>> return unitPH) .) {-# DEPRECATED restriction "same as ((>> return unitPH) .)" #-} -- | Deprecated. restriction' :: (Record Flat r -> Restrict (PlaceHolders p)) -> Restriction p r restriction' = id {-# DEPRECATED restriction' "same as id" #-} fromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> (StringSQL, StringSQL) fromRestriction config tbl q = (qt, composeWhere rs) where (qt, rs) = Restrict.extract (withQualified tbl q) config -- | SQL WHERE clause 'StringSQL' string from 'Restrict' computation. sqlWhereFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL sqlWhereFromRestriction config tbl = snd . fromRestriction config tbl {-# DEPRECATED sqlWhereFromRestriction "low-level API, this API will be expired." #-} -- | DELETE statement with WHERE clause 'StringSQL' string from 'Restrict' computation. deleteFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL deleteFromRestriction config tbl r = DELETE <> FROM <> uncurry (<>) (fromRestriction config tbl r) -- | Show WHERE clause. instance TableDerivable r => Show (Record Flat r -> Restrict (PlaceHolders p)) where show = showStringSQL . snd . fromRestriction defaultConfig derivedTable -- | UpdateTarget type with place-holder parameter 'p' and projected record type 'r'. type UpdateTarget p r = Record Flat r -> Assign r (PlaceHolders p) -- | Deprecated. updateTarget :: (Record Flat r -> Assign r ()) -> UpdateTarget () r updateTarget = ((>> return unitPH) .) {-# DEPRECATED updateTarget "old-style API. Use new-style Database.Relational.updateNoPH." #-} -- | Deprecated. updateTarget' :: (Record Flat r -> Assign r (PlaceHolders p)) -> UpdateTarget p r updateTarget' = id {-# DEPRECATED updateTarget' "same as id" #-} updateAllColumn :: PersistableWidth r => (Record Flat r -> Restrict (PlaceHolders p)) -> (Record Flat r -> Assign r (PlaceHolders (r, p))) updateAllColumn rs proj = do (ph0, ()) <- placeholder (\ph -> id' <-# ph) ph1 <- assignings $ rs proj return $ ph0 >< ph1 -- | Lift 'Restrict' computation to 'Assign' computation. Assign target columns are all. liftTargetAllColumn :: PersistableWidth r => (Record Flat r -> Restrict (PlaceHolders ())) -> (Record Flat r -> Assign r (PlaceHolders r)) liftTargetAllColumn rs = \proj -> fmap peRight $ updateAllColumn rs proj {-# DEPRECATED liftTargetAllColumn "old-style API. use Database.Relational.updateAllColumnNoPH instead of this." #-} -- | Lift 'Restrict' computation to 'Assign' computation. Assign target columns are all. With placefolder type 'p'. liftTargetAllColumn' :: PersistableWidth r => (Record Flat r -> Restrict (PlaceHolders p)) -> (Record Flat r -> Assign r (PlaceHolders (r, p))) liftTargetAllColumn' rs = updateAllColumn rs -- | Deprecated. updateTargetAllColumn :: PersistableWidth r => (Record Flat r -> Restrict ()) -> (Record Flat r -> Assign r (PlaceHolders r)) updateTargetAllColumn = liftTargetAllColumn . restriction {-# DEPRECATED updateTargetAllColumn "Use Database.Relational.updateAllColumnNoPH instead of this." #-} -- | Deprecated. updateTargetAllColumn' :: PersistableWidth r => (Record Flat r -> Restrict (PlaceHolders p)) -> (Record Flat r -> Assign r (PlaceHolders (r, p))) updateTargetAllColumn' = liftTargetAllColumn' {-# DEPRECATED updateTargetAllColumn' "Use Database.Relational.updateAllColumn instead of this." #-} fromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> (StringSQL, StringSQL) fromUpdateTarget config tbl q = (qt, composeSets (asR tbl) <> composeWhere rs) where ((qt, asR), rs) = Assign.extract (withQualified tbl q) config -- | SQL SET clause and WHERE clause 'StringSQL' string from 'Assign' computation. sqlFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL sqlFromUpdateTarget config tbl = snd . fromUpdateTarget config tbl {-# DEPRECATED sqlFromUpdateTarget "low-level API, this API will be expired." #-} -- | UPDATE statement with SET clause and WHERE clause 'StringSQL' string from 'Assign' computation. updateFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL updateFromUpdateTarget config tbl ut = UPDATE <> uncurry (<>) (fromUpdateTarget config tbl ut) -- | Show Set clause and WHERE clause. instance TableDerivable r => Show (Record Flat r -> Assign r (PlaceHolders p)) where show = showStringSQL . snd . fromUpdateTarget defaultConfig derivedTable -- | InsertTarget type with place-holder parameter 'p' and projected 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 unitPH) {-# DEPRECATED insertTarget "old-style API. Use new-style Database.Relational.insertValueNoPH ." #-} -- | Finalize 'Register' monad and generate 'InsertTarget' with place-holder parameter 'p'. insertTarget' :: Register r (PlaceHolders p) -> InsertTarget p r insertTarget' = InsertTarget -- | parametalized 'Register' monad from 'Pi' piRegister :: PersistableWidth r => Pi r r' -> Register r (PlaceHolders r') piRegister pi' = do let (ph', ma) = pwPlaceholder (Pi.width' pi') (\ph -> pi' <-# ph) () <- ma return ph' sqlChunkFromInsertTarget' :: Config -> Int -> Table r -> InsertTarget p r -> StringSQL sqlChunkFromInsertTarget' config sz tbl (InsertTarget q) = INSERT <> INTO <> stringSQL (Table.name tbl) <> composeChunkValuesWithColumns sz (asR tbl) where (_ph, asR) = Register.extract q config countChunks :: Config -> Table r -> Int countChunks config tbl = (th + w - 1) `quot` w where th = chunksInsertSize config w = Table.width tbl -- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget' sqlChunkFromInsertTarget :: Config -> Table r -> InsertTarget p r -> (StringSQL, Int) sqlChunkFromInsertTarget config tbl it = (sqlChunkFromInsertTarget' config n tbl it, n) where n = countChunks config tbl -- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget' sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1 -- | Make 'StringSQL' strings of SQL INSERT strings from records list sqlChunksFromRecordList :: LiteralSQL r' => Config -> Table r -> Pi r r' -> [r'] -> [StringSQL] sqlChunksFromRecordList config tbl pi' xs = [ INSERT <> INTO <> stringSQL (Table.name tbl) <> composeValuesListWithColumns [ tf tbl | r <- rs , let ((), tf) = Register.extract (pi' <-# value r) config ] | rs <- unfoldr step xs ] where n = countChunks config tbl step ys | null ys = Nothing | otherwise = Just $ splitAt n ys relational-query-0.12.2.3/src/Database/Relational/Record.hs0000644000000000000000000001515613633172100021563 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Record -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines interfaces of projected record type. module Database.Relational.Record ( -- * Record data structure and interface Record, width, columns, untype, unsafeFromSqlTerms, unsafeFromQualifiedSubQuery, unsafeFromScalarSubQuery, unsafeFromTable, unsafeStringSql, -- * Projections pi, piMaybe, piMaybe', wpi, flattenMaybe, just, unsafeToAggregated, unsafeToFlat, unsafeChangeContext, unsafeStringSqlNotNullMaybe, -- * List of Record RecordList, list, unsafeListFromSubQuery, unsafeStringSqlList ) where import Prelude hiding (pi) import Data.Functor.ProductIsomorphic (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), ProductIsoEmpty, pureE, peRight, peLeft, ) import qualified Language.SQL.Keyword as SQL import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint, PersistableWidth, persistableWidth) import Database.Record.Persistable (PersistableRecordWidth) import qualified Database.Record.KeyConstraint as KeyConstraint import Database.Relational.Internal.ContextType (Aggregated, Flat) import Database.Relational.Internal.String (StringSQL, listStringSQL, rowStringSQL) import Database.Relational.SqlSyntax (SubQuery, Qualified, Tuple, Record, recordRawColumns, tupleFromJoinedSubQuery,) import qualified Database.Relational.SqlSyntax as Syntax import Database.Relational.Table (Table) import qualified Database.Relational.Table as Table import Database.Relational.Pi (Pi) import qualified Database.Relational.Pi.Unsafe as UnsafePi -- | Unsafely get SQL term from 'Record'. unsafeStringSql :: Record c r -> StringSQL unsafeStringSql = rowStringSQL . recordRawColumns -- | Get column SQL string list of record. columns :: Record c r -- ^ Source 'Record' -> [StringSQL] -- ^ Result SQL string list columns = recordRawColumns -- | Width of 'Record'. width :: Record c r -> Int width = Syntax.recordWidth -- | Get untyped tuple. untype :: Record c r -> Tuple untype = Syntax.untypeRecord -- | Unsafely generate 'Record' from qualified (joined) sub-query. unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Record c t unsafeFromQualifiedSubQuery = Syntax.record . tupleFromJoinedSubQuery -- | Unsafely generate 'Record' from scalar sub-query. unsafeFromScalarSubQuery :: SubQuery -> Record c t unsafeFromScalarSubQuery = Syntax.typeFromScalarSubQuery -- | Unsafely generate unqualified 'Record' from 'Table'. unsafeFromTable :: Table r -> Record c r unsafeFromTable = Syntax.typeFromRawColumns . Table.columns -- | Unsafely generate 'Record' from SQL expression strings. unsafeFromSqlTerms :: [StringSQL] -> Record c t unsafeFromSqlTerms = Syntax.typeFromRawColumns -- | Unsafely trace projection path. unsafeProject :: PersistableRecordWidth a -> Record c a' -> Pi a b -> Record c b' unsafeProject w p pi' = Syntax.typeFromRawColumns . (UnsafePi.pi w pi') . columns $ p -- | Trace projection path to get narrower 'Record'. wpi :: PersistableRecordWidth a -> Record c a -- ^ Source 'Record' -> Pi a b -- ^ Projection path -> Record c b -- ^ Narrower 'Record' wpi = unsafeProject -- | Trace projection path to get narrower 'Record'. pi :: PersistableWidth a => Record c a -- ^ Source 'Record' -> Pi a b -- ^ Record path -> Record c b -- ^ Narrower 'Record' pi = unsafeProject persistableWidth -- | Trace projection path to get narrower 'Record'. From 'Maybe' type to 'Maybe' type. piMaybe :: PersistableWidth a => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type -> Pi a b -- ^ Projection path -> Record c (Maybe b) -- ^ Narrower 'Record'. 'Maybe' type result piMaybe = unsafeProject persistableWidth -- | Trace projection path to get narrower 'Record'. From 'Maybe' type to 'Maybe' type. -- Leaf type of projection path is 'Maybe'. piMaybe' :: PersistableWidth a => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Record c (Maybe b) -- ^ Narrower 'Record'. 'Maybe' type result piMaybe' = unsafeProject persistableWidth unsafeCast :: Record c r -> Record c r' unsafeCast = Syntax.record . Syntax.untypeRecord -- | Composite nested 'Maybe' on record phantom type. flattenMaybe :: Record c (Maybe (Maybe a)) -> Record c (Maybe a) flattenMaybe = unsafeCast -- | Cast into 'Maybe' on record phantom type. just :: Record c r -> Record c (Maybe r) just = unsafeCast -- | Unsafely cast context type tag. unsafeChangeContext :: Record c r -> Record c' r unsafeChangeContext = Syntax.record . Syntax.untypeRecord -- | Unsafely lift to aggregated context. unsafeToAggregated :: Record Flat r -> Record Aggregated r unsafeToAggregated = unsafeChangeContext -- | Unsafely down to flat context. unsafeToFlat :: Record Aggregated r -> Record Flat r unsafeToFlat = unsafeChangeContext notNullMaybeConstraint :: HasColumnConstraint NotNull r => Record c (Maybe r) -> NotNullColumnConstraint r notNullMaybeConstraint = const KeyConstraint.columnConstraint -- | Unsafely get SQL string expression of not null key record. unsafeStringSqlNotNullMaybe :: HasColumnConstraint NotNull r => Record c (Maybe r) -> StringSQL unsafeStringSqlNotNullMaybe p = (!! KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p pempty :: Record c () pempty = Syntax.record [] -- | Map 'Record' which result type is record. instance ProductIsoFunctor (Record c) where _ |$| p = unsafeCast p -- | Compose 'Record' using applicative style. instance ProductIsoApplicative (Record c) where pureP _ = unsafeCast pempty pf |*| pa = Syntax.record $ Syntax.untypeRecord pf ++ Syntax.untypeRecord pa instance ProductIsoEmpty (Record c) () where pureE = pureP () peRight = unsafeCast peLeft = unsafeCast -- | Projected record list type for row list. data RecordList p t = List [p t] | Sub SubQuery -- | Make projected record list from 'Record' list. list :: [p t] -> RecordList p t list = List -- | Make projected record list from 'SubQuery'. unsafeListFromSubQuery :: SubQuery -> RecordList p t unsafeListFromSubQuery = Sub -- | Map record show operatoions and concatinate to single SQL expression. unsafeStringSqlList :: (p t -> StringSQL) -> RecordList p t -> StringSQL unsafeStringSqlList sf = d where d (List ps) = listStringSQL $ map sf ps d (Sub sub) = SQL.paren $ Syntax.showSQL sub relational-query-0.12.2.3/src/Database/Relational/Sequence.hs0000644000000000000000000001242213633172100022106 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Relational.Sequence -- Copyright : 2017-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides structures about sequence tables. module Database.Relational.Sequence ( Sequence, seqTable, seqExtract, seqKey, seqRelation, unsafeSpecifySequence, SeqBinding, boundTable, boundKey, boundSequence, unsafeSpecifyBinding, primaryBinding, SequenceDerivable (..), Binding (..), fromRelation, Number, unsafeSpecifyNumber, extractNumber, ($$!), ($$), updateNumber', updateNumber, ) where import Prelude hiding (seq) import Database.Record (PersistableWidth) import Database.Relational.Internal.Config (Config, defaultConfig) import Database.Relational.Monad.Class (wheres) import Database.Relational.Monad.BaseType (Relation) import Database.Relational.Monad.Trans.Assigning ((<-#)) import Database.Relational.Table (TableDerivable, derivedTable, Table) import Database.Relational.Pi (Pi) import Database.Relational.Constraint (HasConstraintKey (..), Key, Primary, projectionKey) import Database.Relational.Projectable ((.<=.), value, unitPH, (!)) import Database.Relational.ProjectableClass (LiteralSQL) import Database.Relational.Relation (tableOf) import qualified Database.Relational.Relation as Relation import Database.Relational.Type (Update, typedUpdate') -- | Basic record to express sequence-table. -- actual sequence-table is a table which has only one column -- of integer type. data Sequence s i = Sequence { seqTable :: Table s -- ^ actual sequence-table , seqExtract :: s -> i -- ^ sequence number selector for sequence record , seqKey :: Pi s i -- ^ sequence number projection for sequence record } -- | Unsafely specify sequence table. unsafeSpecifySequence :: TableDerivable s => (s -> i) -> Pi s i -> Sequence s i unsafeSpecifySequence = Sequence derivedTable -- | Infer 'Relation' of sequence table seqRelation :: TableDerivable s => Sequence s i -> Relation () s seqRelation = Relation.table . seqTable -- | 'Sequence' derivation rule class TableDerivable s => SequenceDerivable s i | s -> i where derivedSequence :: Sequence s i -- | Record to express binding between normal-table and sequence-table. data SeqBinding r s i = SeqBinding { boundTable :: Table r -- ^ normal-table bound to sequence-table , boundKey :: Pi r i -- ^ sequence key projection for bound record , boundSequence :: Sequence s i -- ^ sequence table record } -- | Unsafely specify binding between normal-table and sequence-table. unsafeSpecifyBinding :: (TableDerivable r, SequenceDerivable s i) => Pi r i -> SeqBinding r s i unsafeSpecifyBinding k = SeqBinding derivedTable k derivedSequence -- | Derive binding using primary key. primaryBinding :: (TableDerivable r, SequenceDerivable s i, HasConstraintKey Primary r i) => SeqBinding r s i primaryBinding = unsafeSpecifyBinding $ primaryKey constraintKey where primaryKey :: Key Primary r ct -> Pi r ct primaryKey = projectionKey -- | Derivation rule for binding between 'Table' and 'Sequence' class (TableDerivable r, SequenceDerivable s i) => Binding r s i | r -> s where binding :: SeqBinding r s i default binding :: HasConstraintKey Primary r i => SeqBinding r s i binding = primaryBinding fromTable :: Binding r s i => Table r -> Sequence s i fromTable = const derivedSequence -- | Derive 'Sequence' from corresponding 'Relation' fromRelation :: Binding r s i => Relation () r -> Sequence s i fromRelation = fromTable . tableOf -- | Sequence number type for record type 'r' newtype Number r i = Number i deriving (Eq, Ord, Show) -- | Unsafely specify sequence number. unsafeSpecifyNumber :: Binding r s i => i -> Number r i unsafeSpecifyNumber = Number -- | Get untyped sequence number. extractNumber :: Number r i -> i extractNumber (Number i) = i -- | Unsafely apply sequence number. ($$!) :: (i -> r) -- ^ sequence number should be passed to proper field of record -> Number r i -> r ($$!) = (. extractNumber) -- | Unsafely apply sequence number. Only safe to build corresponding record type. ($$) :: Binding r s i => (i -> r) -- ^ sequence number should be passed to proper field of record -> Number r i -> r ($$) = ($$!) -- | Update statement for sequence table updateNumber' :: (PersistableWidth s, Integral i, LiteralSQL i) => Config -> i -- ^ sequence number to set. expect not SQL injectable. -> Sequence s i -- ^ sequence table -> Update () updateNumber' config i seqt = typedUpdate' config (seqTable seqt) $ \ proj -> do let iv = value i seqKey seqt <-# iv wheres $ proj ! seqKey seqt .<=. iv -- fool proof return unitPH -- | Update statement for sequence table updateNumber :: (PersistableWidth s, Integral i, LiteralSQL i) => i -- ^ sequence number to set. expect not SQL injectable. -> Sequence s i -- ^ sequence table -> Update () updateNumber = updateNumber' defaultConfig relational-query-0.12.2.3/src/Database/Relational/ProjectableClass.hs0000644000000000000000000000531713633172100023563 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ConstraintKinds #-} -- | -- Module : Database.Relational.ProjectableClass -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides interfaces to preserve constraints of -- direct product projections. module Database.Relational.ProjectableClass ( -- * Literal SQL terms LiteralSQL (..), showLiteral, StringSQL, -- * Deprecated. ShowConstantTermsSQL, showConstantTermsSQL', showConstantTermsSQL, ) where import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from) import Data.Monoid (mempty, (<>)) import Data.DList (DList, toList) import Database.Relational.Internal.String (StringSQL) -- | Convert from haskell record to SQL literal row-value. showLiteral :: LiteralSQL a => a -> [StringSQL] showLiteral = toList . showLiteral' {- | 'LiteralSQL' 'a' is implicit rule to derive function to convert from haskell record type 'a' into SQL literal row-value. Generic programming () with default signature is available for 'LiteralSQL' class, so you can make instance like below: @ \{\-\# LANGUAGE DeriveGeneric \#\-\} import GHC.Generics (Generic) -- data Foo = Foo { ... } deriving Generic instance LiteralSQL Foo @ -} class LiteralSQL a where showLiteral' :: a -> DList StringSQL default showLiteral' :: (Generic a, GLiteralSQL (Rep a)) => a -> DList StringSQL showLiteral' = gShowLiteral . from class GLiteralSQL f where gShowLiteral :: f a -> DList StringSQL instance GLiteralSQL U1 where gShowLiteral U1 = mempty instance (GLiteralSQL a, GLiteralSQL b) => GLiteralSQL (a :*: b) where gShowLiteral (a :*: b) = gShowLiteral a <> gShowLiteral b instance GLiteralSQL a => GLiteralSQL (M1 i c a) where gShowLiteral (M1 a) = gShowLiteral a instance ShowConstantTermsSQL a => GLiteralSQL (K1 i a) where gShowLiteral (K1 a) = showLiteral' a --- {-# DEPRECATED ShowConstantTermsSQL "Use `LiteralSQL` instead of this." #-} -- | Deprecated. type ShowConstantTermsSQL = LiteralSQL {-# DEPRECATED showConstantTermsSQL' "Use `showLiteral'` instead of this." #-} showConstantTermsSQL' :: ShowConstantTermsSQL a => a -> DList StringSQL showConstantTermsSQL' = showLiteral' {-# DEPRECATED showConstantTermsSQL "Use `showLiteral` instead of this." #-} -- | Deprecated. showConstantTermsSQL :: ShowConstantTermsSQL a => a -> [StringSQL] showConstantTermsSQL = toList . showConstantTermsSQL' relational-query-0.12.2.3/src/Database/Relational/NonStandard/0000755000000000000000000000000013633172100022214 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/NonStandard/PureTimestampTZ.hs0000644000000000000000000000147313633172100025632 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} module Database.Relational.NonStandard.PureTimestampTZ () where import Control.Applicative (pure) import Data.Time (UTCTime, ZonedTime) import Language.SQL.Keyword (Keyword (..)) import qualified Database.Relational.Internal.Literal as Lit import Database.Relational.ProjectableClass (LiteralSQL (..)) -- | Constant SQL terms of 'ZonedTime'. -- This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal. instance LiteralSQL ZonedTime where showLiteral' = pure . Lit.timestamp 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 LiteralSQL UTCTime where showLiteral' = pure . Lit.timestamp TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z" relational-query-0.12.2.3/src/Database/Relational/Internal/0000755000000000000000000000000013633172100021555 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/Internal/Literal.hs0000644000000000000000000000257613633172100023517 0ustar0000000000000000-- | -- Module : Database.Relational.Internal.Literal -- Copyright : 2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides definitions to lift haskell expressions -- into SQL expressions. module Database.Relational.Internal.Literal ( stringExpr, bool, integral, timestamp, ) where import Data.Monoid ((<>)) import Data.Time (FormatTime, formatTime) import Data.Time.Locale.Compat (defaultTimeLocale) import Language.SQL.Keyword (Keyword) import Database.Relational.Internal.String (StringSQL, stringSQL) -- | 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. stringExpr :: String -> StringSQL stringExpr = stringSQL . ('\'' :) . (++ "'") . escapeStringToSqlExpr -- | SQL expressions for Bool type. bool :: Bool -> StringSQL bool = stringSQL . d where d True = "(0=0)" d False = "(0=1)" -- | Constant integral SQL term. integral :: (Show a, Integral a) => a -> StringSQL integral = stringSQL . show timestamp :: FormatTime t => Keyword -> String -> t -> StringSQL timestamp kw fmt t = kw <> stringExpr (formatTime defaultTimeLocale fmt t) relational-query-0.12.2.3/src/Database/Relational/Internal/ContextType.hs0000644000000000000000000000145213633172100024401 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Database.Relational.Internal.ContextType -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines query context tag types. module Database.Relational.Internal.ContextType ( Flat, Aggregated, Exists, OverWindow, Set, SetList, Power, ) where -- | Type tag for flat (not-aggregated) query data Flat -- | Type tag for aggregated query data Aggregated -- | Type tag for exists predicate data Exists -- | Type tag for window function building data OverWindow -- | Type tag for normal aggregatings set data Set -- | Type tag for aggregatings GROUPING SETS data SetList -- | Type tag for aggregatings power set data Power relational-query-0.12.2.3/src/Database/Relational/Internal/Config.hs0000644000000000000000000001316713633172100023326 0ustar0000000000000000-- | -- Module : Database.Relational.Internal.Config -- Copyright : 2017-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines configuration datatype used in query products. module Database.Relational.Internal.Config ( Config, defaultConfig, {- field labels of 'Config' type. To avoid haddock bug ( https://github.com/haskell/haddock/issues/456 ), they are not listed in Config ( ... ). -} productUnitSupport, chunksInsertSize, schemaNameMode, normalizedTableName, addQueryTableAliasAS, addModifyTableAliasAS, enableWarning, verboseAsCompilerWarning, disableOverloadedProjection, disableSpecializedProjection, identifierQuotation, nameConfig, NameConfig, defaultNameConfig, {- field labels of 'NameConfig' type. To avoid haddock bug ( https://github.com/haskell/haddock/issues/456 ), they are not listed in NameConfig ( ... ). -} recordConfig, relationVarName, ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), ) where import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) import qualified Database.Record.TH as RecordTH -- | 'NameConfig' type to customize names of expanded templates. data NameConfig = NameConfig { recordConfig :: RecordTH.NameConfig -- ^ Configurations related to the names of generated record types -- and their field labels. , relationVarName :: String -> String -> VarName -- ^ Function to build the name of 'Database.Relational.Monad.BaseType.Relation' representing the table. -- The first argument is the scheme name, and second argument is the table name. } instance Show NameConfig where show = const "" -- | Default implementation of 'NameConfig' type. defaultNameConfig :: NameConfig defaultNameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig , relationVarName = const varCamelcaseName } -- | Unit of product is supported or not. data ProductUnitSupport = PUSupported | PUNotSupported deriving Show -- | Schema name qualify mode in SQL string. data SchemaNameMode = SchemaQualified -- ^ Schema qualified table name in SQL string | SchemaNotQualified -- ^ Not qualified table name in SQL string deriving (Eq, Show) -- | Configuration for quotation of identifiers of SQL. data IdentifierQuotation = NoQuotation | Quotation Char deriving Show -- | Configuration type. data Config = Config { productUnitSupport :: !ProductUnitSupport -- ^ No FROM clause (corresponding the unit of JOIN) is allowed or not. , chunksInsertSize :: !Int -- ^ Threshold count of placeholders in the insert statement with multi-values. , schemaNameMode :: !SchemaNameMode -- ^ 'SchemaNameMode' configuration , normalizedTableName :: !Bool -- ^ If True, schema names become uppercase, and table names become lowercase. , addQueryTableAliasAS :: !Bool -- ^ If True, AS keyword is not skipped but added in table-alias of SELECT statement or correlate SELECT clause. , addModifyTableAliasAS :: !Bool -- ^ If True, AS keyword is not skipped but added in target-table-alias of UPDATE and DELETE statement. , enableWarning :: !Bool -- ^ If True, print warning messages in macros of relational-record. , verboseAsCompilerWarning :: !Bool -- ^ If True, more detailed logs are printed when generating record types from schema. , disableOverloadedProjection :: !Bool -- ^ If True, instance of 'Database.Relational.OverloadedProjection.HasProjection' for each column is NOT generated. , disableSpecializedProjection :: !Bool -- ^ If True, 'Database.Relational.Pi.Pi' for each column is NOT generated. , identifierQuotation :: !IdentifierQuotation -- ^ 'IdentifierQuotation' configuration , nameConfig :: !NameConfig -- ^ 'NameConfig' configuration } deriving Show -- | Default configuration of 'Config'. -- To change some behaviour of relational-query, -- use record update syntax: -- -- @ -- defaultConfig -- { productUnitSupport = 'PUSupported' -- , chunksInsertSize = 256 -- , schemaNameMode = 'SchemaQualified' -- , normalizedTableName = True -- , addQueryTableAliasAS = False -- , addModifyTableAliasAS = False -- , enableWarning = True -- , verboseAsCompilerWarning = False -- , disableOverloadedProjection = False -- , disableSpecializedProjection = False -- , identifierQuotation = 'NoQuotation' -- , nameConfig = -- defaultNameConfig -- { recordConfig = 'RecordTH.defaultNameConfig' -- , relationVarName = \\schema table -> 'varCamelcaseName' $ table ++ "_" ++ scheme -- -- ^ append the table name after the schema name. e.g. "schemaTable" -- } -- } -- @ defaultConfig :: Config defaultConfig = Config { productUnitSupport = PUSupported , chunksInsertSize = 256 , schemaNameMode = SchemaQualified , normalizedTableName = True , addQueryTableAliasAS = False , addModifyTableAliasAS = False , enableWarning = True , verboseAsCompilerWarning = False , disableOverloadedProjection = False , disableSpecializedProjection = False , identifierQuotation = NoQuotation , nameConfig = defaultNameConfig } relational-query-0.12.2.3/src/Database/Relational/Internal/String.hs0000644000000000000000000000247413633172100023366 0ustar0000000000000000-- | -- Module : Database.Relational.Internal.String -- Copyright : 2014-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides SQL string wrap interfaces. module Database.Relational.Internal.String ( 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 "Record: no columns. empty row is not allowed in SQL." 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.12.2.3/src/Database/Relational/Internal/UntypedTable.hs0000644000000000000000000000226113633172100024512 0ustar0000000000000000-- | -- Module : Database.Relational.Internal.UntypedTable -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines no-phantom table type which has table metadatas. module Database.Relational.Internal.UntypedTable ( Untyped (Untyped), name', width', columns', (!), ) where import Data.Array (Array, elems) import qualified Data.Array as Array import Database.Relational.Internal.String (StringSQL) -- | Untyped typed table type data Untyped = Untyped String Int (Array Int StringSQL) 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 StringSQL columnArray (Untyped _ _ c) = c -- | Column name strings in SQL columns' :: Untyped -> [StringSQL] columns' = elems . columnArray -- | Column name string in SQL specified by index (!) :: Untyped -> Int -- ^ Column index -> StringSQL -- ^ Column name String in SQL t ! i = columnArray t Array.! i relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/0000755000000000000000000000000013633172100021747 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/Join.hs0000644000000000000000000000437313633172100023211 0ustar0000000000000000-- | -- Module : Database.Relational.SqlSyntax.Join -- Copyright : 2013-2017 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.SqlSyntax.Join ( -- * Interfaces to manipulate ProductTree type growProduct, restrictProduct, ) where import Prelude hiding (and, product) import Control.Applicative (pure) import Data.Monoid ((<>), mempty) import Data.DList (DList) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax.Types (NodeAttr (..), ProductTree (..), Node (..), Qualified, SubQuery, Predicate) -- | Push new tree into product right term. growRight :: Maybe (Node (DList (Predicate Flat))) -- ^ Current tree -> (NodeAttr, ProductTree (DList (Predicate Flat))) -- ^ New tree to push into right -> Node (DList (Predicate Flat)) -- ^ 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 (Node (DList (Predicate Flat))) -- ^ Current tree -> (NodeAttr, (Bool, Qualified SubQuery)) -- ^ New leaf to push into right -> Node (DList (Predicate Flat)) -- ^ Result node growProduct = match where match t (na, q) = growRight t (na, Leaf q) -- | Add restriction into top product of product tree. restrictProduct' :: ProductTree (DList (Predicate Flat)) -- ^ Product to restrict -> Predicate Flat -- ^ Restriction to add -> ProductTree (DList (Predicate Flat)) -- ^ 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 :: Node (DList (Predicate Flat)) -- ^ Target node which has product to restrict -> Predicate Flat -- ^ Restriction to add -> Node (DList (Predicate Flat)) -- ^ Result node restrictProduct (Node a t) e = Node a (restrictProduct' t e) relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/Query.hs0000644000000000000000000000653313633172100023417 0ustar0000000000000000-- | -- Module : Database.Relational.SqlSyntax.Query -- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides building and expanding operations of SQL query tree. module Database.Relational.SqlSyntax.Query ( flatSubQuery, aggregatedSubQuery, union, except, intersect, caseSearch, case', ) where import Database.Relational.Internal.Config (Config) import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.SqlSyntax.Types (Duplication (..), SetOp (..), BinOp (..), OrderingTerm, AggregateElem, JoinProduct, Predicate, WhenClauses (..), CaseClause (..), SubQuery (..), Column (..), Tuple, Record, record, untypeRecord, recordWidth, ) -- | Unsafely generate flat 'SubQuery' from untyped components. flatSubQuery :: Config -> Tuple -> Duplication -> JoinProduct -> [Predicate Flat] -> [OrderingTerm] -> SubQuery flatSubQuery = Flat -- | Unsafely generate aggregated 'SubQuery' from untyped components. aggregatedSubQuery :: Config -> Tuple -> Duplication -> JoinProduct -> [Predicate Flat] -> [AggregateElem] -> [Predicate Aggregated] -> [OrderingTerm] -> 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 whenClauses :: String -- ^ Error tag -> [(Record c a, Record c b)] -- ^ Each when clauses -> Record c b -- ^ Else result record -> WhenClauses -- ^ Result clause whenClauses eTag ws0 e = d ws0 where d [] = error $ eTag ++ ": Empty when clauses!" d ws@(_:_) = WhenClauses [ (untypeRecord p, untypeRecord r) | (p, r) <- ws ] $ untypeRecord e -- | Search case operator correnponding SQL search /CASE/. -- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ caseSearch :: [(Predicate c, Record c a)] -- ^ Each when clauses -> Record c a -- ^ Else result record -> Record c a -- ^ Result record caseSearch ws e = record [ Case c i | i <- [0 .. recordWidth e - 1] ] where c = CaseSearch $ whenClauses "caseSearch" ws e -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ case' :: Record c a -- ^ Record value to match -> [(Record c a, Record c b)] -- ^ Each when clauses -> Record c b -- ^ Else result record -> Record c b -- ^ Result record case' v ws e = record [ Case c i | i <- [0 .. recordWidth e - 1] ] where c = CaseSimple (untypeRecord v) $ whenClauses "case'" ws e relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/Aggregate.hs0000644000000000000000000000346513633172100024201 0ustar0000000000000000-- | -- Module : Database.Relational.SqlSyntax.Aggregate -- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides grouping-sets structure of SQL syntax tree. module Database.Relational.SqlSyntax.Aggregate ( aggregateColumnRef, aggregatePowerKey, aggregateGroupingSet, aggregateRollup, aggregateCube, aggregateSets, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey, ) where import Database.Relational.SqlSyntax.Types (AggregateBitKey (..), AggregateSet (..), AggregateElem (..), AggregateColumnRef, AggregateKey (..), ) -- | 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 -- | Extract typed record from 'AggregateKey'. aggregateKeyRecord :: AggregateKey a -> a aggregateKeyRecord (AggregateKey (p, _c)) = p -- | Extract untyped term from 'AggregateKey'. aggregateKeyElement :: AggregateKey a -> AggregateElem aggregateKeyElement (AggregateKey (_p, c)) = c -- | Unsafely bind typed-record and untyped-term into 'AggregateKey'. unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a unsafeAggregateKey = AggregateKey relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/Updates.hs0000644000000000000000000000477113633172100023721 0ustar0000000000000000-- | -- Module : Database.Relational.SqlSyntax.Updates -- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides types and expanding operations of SQL update and insert structure. module Database.Relational.SqlSyntax.Updates ( -- * Update and Insert assignments AssignColumn, AssignTerm, Assignment, composeSets, composeChunkValues, composeChunkValuesWithColumns, composeValuesListWithColumns, ) where import Data.Monoid ((<>)) import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Internal.String (StringSQL, rowConsStringSQL) -- | Column SQL String of assignment type AssignColumn = StringSQL -- | Value SQL String of assignment type AssignTerm = StringSQL -- | Assignment pair type Assignment = (AssignColumn, AssignTerm) -- | Compose SET clause from ['Assignment']. composeSets :: [Assignment] -> StringSQL composeSets as = assigns where assignList = foldr (\ (col, term) r -> (col .=. term) : r) [] as assigns | null assignList = error "Update assignment list is null!" | otherwise = SET <> SQL.fold (|*|) assignList -- | Compose VALUES clause from a row of value expressions. composeChunkValues :: Int -- ^ record count per chunk -> [AssignTerm] -- ^ value expression list -> Keyword composeChunkValues n0 vs = VALUES <> cvs where n | n0 >= 1 = n0 | otherwise = error $ "Invalid record count value: " ++ show n0 cvs = SQL.fold (|*|) . replicate n $ rowConsStringSQL vs -- | Compose columns row and VALUES clause from a row of value expressions. composeChunkValuesWithColumns :: Int -- ^ record count per chunk -> [Assignment] -- ^ -> StringSQL composeChunkValuesWithColumns sz as = rowConsStringSQL cs <> composeChunkValues sz vs where (cs, vs) = unzip as -- | Compose columns row and VALUES clause from rows list of value expressions. composeValuesListWithColumns :: [[Assignment]] -> StringSQL composeValuesListWithColumns pss = rowConsStringSQL cs <> VALUES <> SQL.fold (|*|) (map rowConsStringSQL vss) where cs = case pss of [] -> error "insertValueList: no assignment chunks" ps:_ -> fst $ unzip ps vss = map (snd . unzip) pss relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/Types.hs0000644000000000000000000001337413633172100023417 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | -- Module : Database.Relational.SqlSyntax.Types -- Copyright : 2015-2018 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.SqlSyntax.Types ( -- * The SubQuery SubQuery (..), -- * Set operations Duplication (..), SetOp (..), BinOp (..), -- * Qualifiers for nested query Qualifier (..), Qualified (..), qualifier, unQualify, qualify, -- * Ordering types Order (..), Nulls (..), OrderColumn, OrderingTerm, -- * Aggregating types AggregateColumnRef, AggregateBitKey (..), AggregateSet (..), AggregateElem (..), AggregateKey (..), -- * Product tree type NodeAttr (..), ProductTree (..), Node (..), nodeAttr, nodeTree, JoinProduct, -- * Case CaseClause (..), WhenClauses(..), -- * Column, Tuple, Record and Projection Column (..), Tuple, tupleWidth, Record, untypeRecord, record, PI, recordWidth, typeFromRawColumns, typeFromScalarSubQuery, -- * Predicate to restrict Query result Predicate, ) where import Prelude hiding (and, product) import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Database.Relational.Internal.Config (Config) import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.Internal.String (StringSQL) import Database.Relational.Internal.UntypedTable (Untyped) -- | Result record duplication attribute data Duplication = All | Distinct deriving Show -- | Set operators data SetOp = Union | Except | Intersect deriving Show -- | Set binary operators newtype BinOp = BinOp (SetOp, Duplication) deriving Show -- | Order direction. Ascendant or Descendant. data Order = Asc | Desc deriving Show -- | Order of null. data Nulls = NullsFirst | NullsLast deriving Show -- | Type for order-by column type OrderColumn = Column -- | Type for order-by term type OrderingTerm = ((Order, Maybe Nulls), OrderColumn) -- | Type for group-by term type AggregateColumnRef = Column -- | Type for group key. newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show -- | Type for grouping set newtype AggregateSet = AggregateSet [AggregateElem] deriving Show -- | Type for group-by tree data AggregateElem = ColumnRef AggregateColumnRef | Rollup [AggregateBitKey] | Cube [AggregateBitKey] | GroupingSets [AggregateSet] deriving Show -- | Typeful aggregate element. newtype AggregateKey a = AggregateKey (a, AggregateElem) -- | Sub-query type data SubQuery = Table Untyped | Flat Config Tuple Duplication JoinProduct [Predicate Flat] [OrderingTerm] | Aggregated Config Tuple Duplication JoinProduct [Predicate Flat] [AggregateElem] [Predicate Aggregated] [OrderingTerm] | Bin BinOp SubQuery SubQuery deriving Show -- | Qualifier type. newtype Qualifier = Qualifier Int deriving Show -- | Qualified query. data Qualified a = Qualified Qualifier a deriving (Show, Functor, Foldable, Traversable) -- | Get qualifier qualifier :: Qualified a -> Qualifier qualifier (Qualified q _) = q -- | Unqualify. unQualify :: Qualified a -> a unQualify (Qualified _ a) = a -- | Add qualifier qualify :: Qualifier -> a -> Qualified a qualify = Qualified -- | node attribute for product. data NodeAttr = Just' | Maybe deriving Show -- | Product tree type. Product tree is constructed by left node and right node. data ProductTree rs = Leaf (Bool, Qualified SubQuery) | 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) -- | 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 -- | Type for join product of query. type JoinProduct = Maybe (ProductTree [Predicate Flat]) -- | when clauses data WhenClauses = WhenClauses [(Tuple, Tuple)] Tuple deriving Show -- | case clause data CaseClause = CaseSearch WhenClauses | CaseSimple Tuple WhenClauses deriving Show -- | Projected column structure unit with single column width data Column = RawColumn StringSQL -- ^ used in immediate value or unsafe operations | SubQueryRef (Qualified Int) -- ^ normalized sub-query reference T with Int index | Scalar SubQuery -- ^ scalar sub-query | Case CaseClause Int -- ^ th column of case clause deriving Show -- | Untyped projected tuple. Forgot record type. type Tuple = [Column] -- | Width of 'Tuple'. tupleWidth :: Tuple -> Int tupleWidth = length -- | Phantom typed record. Projected into Haskell record type 't'. newtype Record c t = Record { untypeRecord :: Tuple {- ^ Discard record type -} } deriving Show -- | Type for predicate to restrict of query result. type Predicate c = Record c (Maybe Bool) -- | Type for projection function. type PI c a b = Record c a -> Record c b -- | Unsafely type 'Tuple' value to 'Record' type. record :: Tuple -> Record c t record = Record -- | Width of 'Record'. recordWidth :: Record c r -> Int recordWidth = length . untypeRecord -- | Unsafely generate 'Record' from SQL string list. typeFromRawColumns :: [StringSQL] -- ^ SQL string list specifies columns -> Record c r -- ^ Result 'Record' typeFromRawColumns = record . map RawColumn -- | Unsafely generate 'Record' from scalar sub-query. typeFromScalarSubQuery :: SubQuery -> Record c t typeFromScalarSubQuery = record . (:[]) . Scalar relational-query-0.12.2.3/src/Database/Relational/SqlSyntax/Fold.hs0000644000000000000000000002746113633172100023201 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.SqlSyntax.Fold -- Copyright : 2013-2019 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.SqlSyntax.Fold ( -- * Sub-query showSQL, toSQL, unitSQL, width, -- * Qualified Sub-query queryWidth, corrSubQueryTerm, -- * Sub-query columns column, -- * Tuple and Record tupleFromJoinedSubQuery, recordRawColumns, -- * Query restriction composeWhere, composeHaving, -- * Aggregation composeGroupBy, composePartitionBy, -- * Ordering composeOrderBy, ) where import Control.Applicative ((<$>), pure) import Data.Monoid (mempty, (<>), mconcat) import Data.Traversable (traverse) import Language.SQL.Keyword (Keyword(..), (|*|)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.Internal.Config (Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported), ) import Database.Relational.Internal.UntypedTable ((!)) import qualified Database.Relational.Internal.UntypedTable as UntypedTable import Database.Relational.Internal.String (StringSQL, stringSQL, rowStringSQL, showStringSQL, ) import qualified Database.Relational.Internal.Literal as Lit import Database.Relational.SqlSyntax.Types (SubQuery (..), Record, Tuple, Predicate, Column (..), CaseClause(..), WhenClauses (..), NodeAttr (Just', Maybe), ProductTree (Leaf, Join), JoinProduct, Duplication (..), SetOp (..), BinOp (..), Qualifier (..), Qualified (..), AggregateBitKey (..), AggregateSet (..), AggregateElem (..), AggregateColumnRef, Order (..), Nulls (..), OrderingTerm, ) import qualified Database.Relational.SqlSyntax.Types as Syntax -- | Compose duplication attribute string. showsDuplication :: Duplication -> StringSQL showsDuplication = dup where dup All = ALL dup Distinct = DISTINCT 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 -- | Alias string from qualifier showQualifier :: Qualifier -> StringSQL showQualifier (Qualifier i) = stringSQL $ 'T' : show i -- | Binary operator to qualify. (<.>) :: Qualifier -> StringSQL -> StringSQL i <.> n = showQualifier i SQL.<.> n columnN :: Int -> StringSQL columnN i = stringSQL $ 'f' : show i asColumnN :: StringSQL -> Int -> StringSQL c `asColumnN` n =c `SQL.as` columnN n -- | Qualified expression from qualifier and projection index. columnFromId :: Qualifier -> Int -> StringSQL columnFromId qi i = qi <.> columnN i -- | Width of 'SubQuery'. width :: SubQuery -> Int width = d where d (Table u) = UntypedTable.width' u d (Bin _ l _) = width l d (Flat _ up _ _ _ _) = Syntax.tupleWidth up d (Aggregated _ up _ _ _ _ _ _) = Syntax.tupleWidth up -- | Width of 'Qualified' 'SubQUery'. queryWidth :: Qualified SubQuery -> Int queryWidth = width . Syntax.unQualify -- | Generate SQL from table for top-level. fromTableToSQL :: UntypedTable.Untyped -> StringSQL fromTableToSQL t = SELECT <> SQL.fold (|*|) (UntypedTable.columns' t) <> FROM <> stringSQL (UntypedTable.name' t) -- | Generate normalized column SQL from table. fromTableToNormalizedSQL :: UntypedTable.Untyped -> StringSQL fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <> FROM <> stringSQL (UntypedTable.name' t) where columns' = zipWith asColumnN (UntypedTable.columns' t) [(0 :: Int)..] -- | Generate normalized column SQL from joined tuple. selectPrefixSQL :: Tuple -> Duplication -> StringSQL selectPrefixSQL up da = SELECT <> showsDuplication da <> SQL.fold (|*|) columns' where columns' = zipWith asColumnN (map showColumn up) [(0 :: Int)..] -- | Normalized column SQL for union like operations -- to keep compatibility with engines like Sqlite and MySQL. -- SQL with no ordering term is not paren-ed. 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 -- | 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 $ UntypedTable.name' u, fromTableToSQL u) d (Bin (BinOp (op, da)) l r) = (SQL.paren q, q) where q = mconcat [normalizedSQL l, showsSetOp op da, normalizedSQL r] d (Flat cf up da pd rs od) = (SQL.paren q, q) where 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 -- | Term of qualified table or qualified subquery, -- used in join-clause of SELECT, correlated UPDATE and DELETE statements. -- When SubQuery is table, expression will be like
[AS] T corrSubQueryTerm :: Bool -- ^ if True, add AS keyword. SQLite causes syntax error on UPDATE or DELETE statement. -> Qualified SubQuery -- ^ subquery structure with qualifier -> StringSQL -- ^ result SQL string corrSubQueryTerm addAS qq = showUnitSQL (Syntax.unQualify qq) `asOP` showQualifier (Syntax.qualifier qq) where asOP = if addAS then SQL.as else (<>) -- | Get column SQL string of 'Qualified' 'SubQuery'. column :: Qualified SubQuery -> Int -> StringSQL column qs = d (Syntax.unQualify qs) where q = Syntax.qualifier qs d (Table u) i = q <.> (u ! i) d (Bin {}) i = q `columnFromId` i d (Flat _ up _ _ _ _) i = showTupleIndex up i d (Aggregated _ up _ _ _ _ _ _) i = showTupleIndex up i -- | Make untyped tuple (qualified column list) from joined sub-query ('Qualified' 'SubQuery'). tupleFromJoinedSubQuery :: Qualified SubQuery -> Tuple tupleFromJoinedSubQuery qs = d $ Syntax.unQualify qs where normalized = SubQueryRef <$> traverse (\q -> [0 .. width q - 1]) qs d (Table _) = map RawColumn . map (column qs) $ take (queryWidth qs) [0..] d (Bin {}) = normalized d (Flat {}) = normalized d (Aggregated {}) = normalized -- | index result of each when clause and else clause. indexWhensClause :: WhenClauses -> Int -> StringSQL indexWhensClause (WhenClauses ps e) i = mconcat [ when' p r | (p, r) <- ps] <> else' <> SQL.END where when' p r = SQL.WHEN <> rowStringSQL (map showColumn p) <> SQL.THEN <> showTupleIndex r i else' = SQL.ELSE <> showTupleIndex e i -- | index result of each when clause and else clause. caseClause :: CaseClause -> Int -> StringSQL caseClause c i = d c where d (CaseSearch wcl) = SQL.CASE <> indexWhensClause wcl i d (CaseSimple m wcl) = SQL.CASE <> rowStringSQL (map showColumn m) <> indexWhensClause wcl i -- | Convert from typed' Column' into column string expression. showColumn :: Column -> StringSQL showColumn = d where d (RawColumn e) = e d (SubQueryRef qi) = Syntax.qualifier qi `columnFromId` Syntax.unQualify qi d (Scalar sub) = showUnitSQL sub d (Case c i) = caseClause c i -- | Get column SQL string of 'Tuple'. showTupleIndex :: Tuple -- ^ Source 'Tuple' -> Int -- ^ Column index -> StringSQL -- ^ Result SQL string showTupleIndex up i | 0 <= i && i < Syntax.tupleWidth up = showColumn $ up !! i | otherwise = error $ "showTupleIndex: index out of bounds: " ++ show i -- | Get column SQL string list of record. recordRawColumns :: Record c r -- ^ Source 'Record' -> [StringSQL] -- ^ Result SQL string list recordRawColumns = map showColumn . Syntax.untypeRecord -- | Show product tree of query into SQL. StringSQL result. showsQueryProduct :: ProductTree [Predicate Flat] -> StringSQL showsQueryProduct = rec where joinType Just' Just' = INNER joinType Just' Maybe = LEFT joinType Maybe Just' = RIGHT joinType Maybe Maybe = FULL urec n = case Syntax.nodeTree n of p@(Leaf _) -> rec p p@(Join {}) -> SQL.paren (rec p) rec (Leaf q) = uncurry corrSubQueryTerm q rec (Join left' right' rs) = mconcat [urec left', joinType (Syntax.nodeAttr left') (Syntax.nodeAttr right'), JOIN, urec right', ON, foldr1 SQL.and $ ps ++ concat [ pure $ Lit.bool True | null ps ] ] where ps = [ rowStringSQL $ recordRawColumns 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 -> [Predicate c] -> StringSQL composeRestrict k = d where d [] = mempty d ps@(_:_) = k <> foldr1 SQL.and [ rowStringSQL $ recordRawColumns p | p <- ps ] -- | Compose WHERE clause from 'QueryRestriction'. composeWhere :: [Predicate Flat] -> StringSQL composeWhere = composeRestrict WHERE -- | Compose HAVING clause from 'QueryRestriction'. composeHaving :: [Predicate Aggregated] -> StringSQL composeHaving = composeRestrict HAVING ----- 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 id $ map showColumn 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) = showColumn 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 showColumn ts) ----- -- | Compose ORDER BY clause from OrderingTerms composeOrderBy :: [OrderingTerm] -> StringSQL composeOrderBy = d where d [] = mempty d ts@(_:_) = ORDER <> BY <> SQL.fold (|*|) (map showsOt ts) showsOt ((o, mn), e) = showColumn e <> order o <> maybe mempty ((NULLS <>) . nulls) mn order Asc = ASC order Desc = DESC nulls NullsFirst = FIRST nulls NullsLast = LAST relational-query-0.12.2.3/src/Database/Relational/Monad/0000755000000000000000000000000013633172100021037 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/Monad/Type.hs0000644000000000000000000000257613633172100022326 0ustar0000000000000000-- | -- Module : Database.Relational.Monad.Type -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines core query type. module Database.Relational.Monad.Type ( -- * Core query monad QueryCore, extractCore, OrderedQuery, ) where import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Duplication, Record, JoinProduct, Predicate, ) import Database.Relational.Projectable (PlaceHolders) import Database.Relational.Monad.BaseType (ConfigureQuery) import Database.Relational.Monad.Trans.Join (QueryJoin, extractProduct) import Database.Relational.Monad.Trans.Restricting (Restrictings, extractRestrict) import Database.Relational.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, [Predicate Flat]), JoinProduct), Duplication) extractCore = extractProduct . extractRestrict -- | OrderedQuery monad type with placeholder type 'p'. Record must be the same as 'Orderings' context type parameter 'c'. type OrderedQuery c m p r = Orderings c m (PlaceHolders p, Record c r) relational-query-0.12.2.3/src/Database/Relational/Monad/Class.hs0000644000000000000000000000710113633172100022437 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Class -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines query building interface classes. module Database.Relational.Monad.Class ( -- * Query interface classes MonadQualify (..), MonadRestrict (..), MonadQuery (..), MonadAggregate (..), MonadPartition (..), all', distinct, on, wheres, having, ) where import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.SqlSyntax (Duplication (..), Predicate, Record, AggregateKey) import Database.Relational.Projectable (PlaceHolders) import Database.Relational.Monad.BaseType (ConfigureQuery, Relation) -- | Restrict context interface class (Functor m, Monad m) => MonadRestrict c m where -- | Add restriction to this context. restrict :: Predicate c -- ^ 'Record' 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 :: Predicate Flat -- ^ 'Record' 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, Record Flat r) -- | Join sub-query with place-holder parameter 'p'. Query result is 'Maybe'. queryMaybe' :: Relation p r -> m (PlaceHolders p, Record 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 record. groupBy :: Record Flat r -- ^ Record to add into group by -> m (Record Aggregated r) -- ^ Result context and aggregated record -- | Add /GROUP BY/ term into context and get aggregated record. Non-traditional group-by version. groupBy' :: AggregateKey (Record Aggregated r) -- ^ Key to aggretate for non-traditional group-by interface -> m (Record Aggregated r) -- ^ Result context and aggregated record -- | Window specification building interface. class Monad m => MonadPartition c m where -- | Add /PARTITION BY/ term into context. partitionBy :: Record 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. Record type version. on :: MonadQuery m => Predicate Flat -> m () on = restrictJoin -- | Add restriction to this not aggregated query. wheres :: MonadRestrict Flat m => Predicate Flat -> m () wheres = restrict -- | Add restriction to this aggregated query. Aggregated Record type version. having :: MonadRestrict Aggregated m => Predicate Aggregated -> m () having = restrict relational-query-0.12.2.3/src/Database/Relational/Monad/Simple.hs0000644000000000000000000000470213633172100022627 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Simple -- Copyright : 2013-2017 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.Monad.Simple ( -- * Simple query QuerySimple, SimpleQuery, simple, toSQL, toSubQuery, ) where import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Duplication, OrderingTerm, JoinProduct, Predicate, Record, SubQuery, flatSubQuery, ) import qualified Database.Relational.SqlSyntax as Syntax import qualified Database.Relational.Record as Record import Database.Relational.Monad.Trans.Join (join') import Database.Relational.Monad.Trans.Restricting (restrictings) import Database.Relational.Monad.Trans.Ordering (Orderings, orderings, extractOrderingTerms) import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Monad.Type (QueryCore, extractCore, OrderedQuery) import Database.Relational.Projectable (PlaceHolders) -- | Simple (not-aggregated) query monad type. type QuerySimple = Orderings Flat QueryCore -- | Simple (not-aggregated) query type. 'SimpleQuery'' p r == 'QuerySimple' ('PlaceHolders' p, 'Record' 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, Record Flat r), [OrderingTerm]), [Predicate 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 Syntax.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 (Record.untype pj) da pd rs ot relational-query-0.12.2.3/src/Database/Relational/Monad/Register.hs0000644000000000000000000000174313633172100023164 0ustar0000000000000000-- | -- Module : Database.Relational.Monad.Register -- Copyright : 2015-2017 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.Monad.Register ( -- * Monad to register target records. Register, extract, ) where import Database.Relational.Internal.Config (Config) import Database.Relational.SqlSyntax (Assignment) import Database.Relational.Table (Table) import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery) import Database.Relational.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 -> [Assignment]) extract = configureQuery . extractAssignments relational-query-0.12.2.3/src/Database/Relational/Monad/Assign.hs0000644000000000000000000000271313633172100022622 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Assign -- Copyright : 2013-2019 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.Monad.Assign ( -- * Monad to restrict target records with assignment. Assign, AssignStatement, extract, ) where import Database.Relational.Internal.Config (Config) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Predicate, Record, Assignment) import Database.Relational.Table (Table) import Database.Relational.Monad.Restrict (Restrict) import qualified Database.Relational.Monad.Restrict as Restrict import Database.Relational.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. -- Record type must be -- the same as 'Target' type parameter 'r'. type AssignStatement r a = Record Flat r -> Assign r a -- | Run 'Assign'. extract :: Assign r a -> Config -> ((a, Table r -> [Assignment]), [Predicate Flat]) extract = Restrict.extract . extractAssignments relational-query-0.12.2.3/src/Database/Relational/Monad/Restrict.hs0000644000000000000000000000246313633172100023177 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Restrict -- Copyright : 2013-2019 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.Monad.Restrict ( -- * Monad to restrict target records. Restrict, RestrictedStatement, extract ) where import Database.Relational.Internal.ContextType (Flat) import Database.Relational.Internal.Config (Config) import Database.Relational.SqlSyntax (Predicate, Record) import Database.Relational.Monad.Trans.Restricting (Restrictings, extractRestrict) import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery) -- | Restrict only monad type used from update statement and delete statement. type Restrict = Restrictings Flat ConfigureQuery -- | RestrictedStatement type synonym. -- Record type 'r' must be -- the same as 'Restrictings' type parameter 'r'. type RestrictedStatement r a = Record Flat r -> Restrict a -- | Run 'Restrict' to get 'QueryRestriction'. extract :: Restrict a -> Config -> (a, [Predicate Flat]) extract = configureQuery . extractRestrict relational-query-0.12.2.3/src/Database/Relational/Monad/Aggregate.hs0000644000000000000000000000766213633172100023274 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Aggregate -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about aggregated query type. module Database.Relational.Monad.Aggregate ( -- * Aggregated Query QueryAggregate, AggregatedQuery, toSQL, toSubQuery, Window, over ) where import Data.Functor.Identity (Identity (runIdentity)) import Data.Monoid ((<>)) import Language.SQL.Keyword (Keyword(..)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow) import Database.Relational.SqlSyntax (Duplication, Record, SubQuery, Predicate, JoinProduct, OrderingTerm, composeOrderBy, aggregatedSubQuery, AggregateColumnRef, AggregateElem, composePartitionBy, ) import qualified Database.Relational.SqlSyntax as Syntax import qualified Database.Relational.Record as Record import Database.Relational.Projectable (PlaceHolders, SqlContext) import Database.Relational.Monad.Class (MonadRestrict(..)) import Database.Relational.Monad.Trans.Restricting (Restrictings, restrictings, extractRestrict) import Database.Relational.Monad.Trans.Aggregating (extractAggregateTerms, AggregatingSetT, PartitioningSet) import Database.Relational.Monad.Trans.Ordering (Orderings, extractOrderingTerms) import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.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, 'Record' '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, Record Aggregated r), [OrderingTerm]), [Predicate Aggregated]), [AggregateElem]), [Predicate 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 Syntax.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 (Record.untype pj) da pd rs ag grs ot extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef]) extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms -- | Operator to make record of window function result using built 'Window' monad. over :: SqlContext c => Record OverWindow a -> Window c () -> Record c a wp `over` win = Record.unsafeFromSqlTerms [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot) | c <- Record.columns wp ] where (((), ot), pt) = extractWindow win infix 8 `over` relational-query-0.12.2.3/src/Database/Relational/Monad/BaseType.hs0000644000000000000000000000663313633172100023117 0ustar0000000000000000-- | -- Module : Database.Relational.Monad.BaseType -- Copyright : 2015-2017 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.Monad.BaseType ( -- * Base monad type to build queries ConfigureQuery, configureQuery, qualifyQuery, askConfig, -- * Relation type Relation, unsafeTypeRelation, untypeRelation, relationWidth, dump, sqlFromRelationWith, sqlFromRelation, rightPh, leftPh, ) where import Data.Functor.Identity (Identity, runIdentity) import Control.Applicative ((<$>)) import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth) import Database.Relational.Internal.String (StringSQL, showStringSQL) import Database.Relational.Internal.Config (Config, defaultConfig) import Database.Relational.SqlSyntax (Qualified, SubQuery, showSQL, width) import qualified Database.Relational.Monad.Trans.Qualify as Qualify import Database.Relational.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) import Database.Relational.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 -- | 'PersistableRecordWidth' of 'Relation' type. relationWidth :: Relation p r -> PersistableRecordWidth r relationWidth rel = unsafePersistableRecordWidth . width $ configureQuery (untypeRelation rel) defaultConfig --- Assume that width is independent from Config structure 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.12.2.3/src/Database/Relational/Monad/Unique.hs0000644000000000000000000000455113633172100022646 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Monad.Unique -- Copyright : 2014-2017 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.Monad.Unique ( QueryUnique, unsafeUniqueSubQuery, toSubQuery, ) where import Control.Applicative (Applicative) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Duplication, Record, JoinProduct, NodeAttr, SubQuery, Predicate, Qualified, ) import qualified Database.Relational.Record as Record import Database.Relational.Projectable (PlaceHolders) import Database.Relational.Monad.Class (MonadQualify, MonadQuery) import Database.Relational.Monad.Trans.Join (unsafeSubQueryWithAttr) import Database.Relational.Monad.Trans.Restricting (restrictings) import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Monad.Type (QueryCore, extractCore) import Database.Relational.SqlSyntax (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 (Record c r) -- ^ Result joined context and record of 'SubQuery' result. unsafeUniqueSubQuery a = QueryUnique . restrictings . unsafeSubQueryWithAttr a extract :: QueryUnique a -> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication) extract (QueryUnique c) = extractCore c -- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. toSubQuery :: QueryUnique (PlaceHolders p, Record 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 (Record.untype pj) da pd rs [] relational-query-0.12.2.3/src/Database/Relational/Monad/Trans/0000755000000000000000000000000013633172100022126 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/Monad/Trans/Config.hs0000644000000000000000000000234513633172100023673 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Monad.Trans.Config -- Copyright : 2013-2017 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.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.Internal.Config (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.12.2.3/src/Database/Relational/Monad/Trans/Join.hs0000644000000000000000000001026613633172100023366 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Trans.Join -- Copyright : 2013-2019 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.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.Internal.ContextType (Flat) import Database.Relational.Internal.Config (addQueryTableAliasAS) import Database.Relational.SqlSyntax (Duplication (All), NodeAttr (Just', Maybe), Predicate, Record, SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, ) import Database.Relational.Monad.Class (liftQualify) import Database.Relational.Monad.Trans.JoinState (JoinContext, primeJoinContext, updateProduct, joinProduct) import qualified Database.Relational.Record as Record import Database.Relational.Projectable (PlaceHolders, unsafeAddPlaceHolders) import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig, qualifyQuery, Relation, untypeRelation) import Database.Relational.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 => Predicate Flat -> 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, Record.just pj) -- | Unsafely join sub-query with this query. unsafeSubQueryWithAttr :: MonadQualify ConfigureQuery q => NodeAttr -- ^ Attribute maybe or just -> Qualified SubQuery -- ^ 'SubQuery' to join -> QueryJoin q (Record c r) -- ^ Result joined context and record of 'SubQuery' result. unsafeSubQueryWithAttr attr qsub = do addAS <- addQueryTableAliasAS <$> liftQualify askConfig updateContext (updateProduct (`growProduct` (attr, (addAS, qsub)))) return $ Record.unsafeFromQualifiedSubQuery qsub -- | Basic monadic join operation using 'MonadQuery'. queryWithAttr :: NodeAttr -> Relation p r -> QueryJoin ConfigureQuery (PlaceHolders p, Record 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.12.2.3/src/Database/Relational/Monad/Trans/Qualify.hs0000644000000000000000000000316613633172100024102 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Monad.Trans.Qualify -- Copyright : 2013-2019 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which qualify uniquely SQL table forms. -- -- This is not public interface. module Database.Relational.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, ap) import qualified Database.Relational.SqlSyntax as Syntax -- | Monad type to qualify SQL table forms. newtype Qualify m a = Qualify (StateT Int 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 Syntax.Qualifier newAlias = Qualify $ do ai <- Syntax.Qualifier `liftM` 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 (Syntax.Qualified query) -- ^ Result with updated state qualifyQuery query = Syntax.qualify `liftM` newAlias `ap` return query relational-query-0.12.2.3/src/Database/Relational/Monad/Trans/Restricting.hs0000644000000000000000000000471013633172100024761 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Trans.Restricting -- Copyright : 2014-2017 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.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.SqlSyntax (Predicate) import Database.Relational.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 (Predicate c)) 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 => Predicate c -> 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, [Predicate c]) extractRestrict (Restrictings rc) = second toList <$> runWriterT rc relational-query-0.12.2.3/src/Database/Relational/Monad/Trans/Assigning.hs0000644000000000000000000000536113633172100024411 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Trans.Assigning -- Copyright : 2013-2019 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.Monad.Trans.Assigning ( -- * Transformer into context with assignments Assignings, assignings, -- * API of context with assignments assignTo, (<-#), AssignTarget, -- * Result SQL set clause extractAssignments ) 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.Monoid (mconcat) import Data.DList (DList, toList) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Record, Assignment) import Database.Relational.Pi (Pi) import Database.Relational.Table (Table, recordWidth) import qualified Database.Relational.Record as Record import Database.Relational.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 targetRecord :: AssignTarget r v -> Table r -> Record Flat v targetRecord pi' tbl = Record.wpi (recordWidth tbl) (Record.unsafeFromTable tbl) pi' -- | Add an assignment. assignTo :: Monad m => Record Flat v -> AssignTarget r v -> Assignings r m () assignTo vp target = Assignings . tell $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where leftsR = Record.columns . targetRecord target rights = Record.columns vp -- | Add and assginment. (<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m () (<-#) = flip assignTo infix 4 <-# -- | Run 'Assignings' to get ['Assignment'] extractAssignments :: (Monad m, Functor m) => Assignings r m a -> m (a, Table r -> [Assignment]) extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac relational-query-0.12.2.3/src/Database/Relational/Monad/Trans/Aggregating.hs0000644000000000000000000001426713633172100024713 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Trans.Aggregating -- Copyright : 2013-2018 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.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.Internal.ContextType (Flat, Aggregated, Set, Power, SetList) import Database.Relational.SqlSyntax (Record, untypeRecord, AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets, AggregateKey, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey) import qualified Database.Relational.Record as Record import Database.Relational.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 $ aggregateKeyRecord k -- | Aggregated query instance. instance MonadQuery m => MonadAggregate (AggregatingSetT m) where groupBy p = do mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- untypeRecord p] return $ Record.unsafeToAggregated p groupBy' = aggregateKey -- | Partition clause instance instance Monad m => MonadPartition c (PartitioningSetT c m) where partitionBy = mapM_ unsafeAggregateWithTerm . untypeRecord -- | 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 Record. key :: Record Flat r -> AggregatingSet (Record Aggregated (Maybe r)) key p = do mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- untypeRecord p] return . Record.just $ Record.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 :: Record Flat r -> AggregatingPowerSet (Record Aggregated (Maybe r)) bkey p = do unsafeAggregateWithTerm . aggregatePowerKey $ untypeRecord p return . Record.just $ Record.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.12.2.3/src/Database/Relational/Monad/Trans/JoinState.hs0000644000000000000000000000256113633172100024366 0ustar0000000000000000-- | -- Module : Database.Relational.Monad.Trans.JoinState -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides state definition for -- "Database.Relational.Monad.Trans.Join". -- -- This is not public interface. module Database.Relational.Monad.Trans.JoinState ( -- * Join context JoinContext, primeJoinContext, updateProduct, joinProduct ) where import Prelude hiding (product) import Data.DList (DList, toList) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (JoinProduct, Node, Predicate) import qualified Database.Relational.SqlSyntax as Product -- | JoinContext type for QueryJoin. newtype JoinContext = JoinContext { product :: Maybe (Node (DList (Predicate Flat))) } -- | Initial 'JoinContext'. primeJoinContext :: JoinContext primeJoinContext = JoinContext Nothing -- | Update product of 'JoinContext'. updateProduct :: (Maybe (Node (DList (Predicate Flat))) -> Node (DList (Predicate Flat))) -> 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.12.2.3/src/Database/Relational/Monad/Trans/Ordering.hs0000644000000000000000000000746413633172100024246 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Monad.Trans.Ordering -- Copyright : 2013-2018 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.Monad.Trans.Ordering ( -- * Transformer into query with ordering Orderings, orderings, -- * API of query with ordering orderBy', 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.SqlSyntax (Order (..), Nulls (..), OrderingTerm, Record, untypeRecord) import Database.Relational.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) -- | Type to accumulate ordering context. -- Type 'c' is ordering term record 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 -- | Add ordering terms. updateOrderBys :: Monad m => (Order, Maybe Nulls) -- ^ Order direction -> Record c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering updateOrderBys opair p = Orderings . mapM_ tell $ terms where terms = curry pure opair `map` untypeRecord p -- | Add ordering terms with null ordering. orderBy' :: Monad m => Record c t -- ^ Ordering terms to add -> Order -- ^ Order direction -> Nulls -- ^ Order of null -> Orderings c m () -- ^ Result context with ordering orderBy' p o n = updateOrderBys (o, Just n) p -- | Add ordering terms. orderBy :: Monad m => Record c t -- ^ Ordering terms to add -> Order -- ^ Order direction -> Orderings c m () -- ^ Result context with ordering orderBy p o = updateOrderBys (o, Nothing) p -- | Add ascendant ordering term. asc :: Monad m => Record c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering asc = updateOrderBys (Asc, Nothing) -- | Add descendant ordering term. desc :: Monad m => Record c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering desc = updateOrderBys (Desc, Nothing) -- | Run 'Orderings' to get 'OrderingTerms' extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, [OrderingTerm]) extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc relational-query-0.12.2.3/src/Database/Relational/Projectable/0000755000000000000000000000000013633172100022233 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/Projectable/Instances.hs0000644000000000000000000000412213633172100024515 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Projectable.Instances -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides instances between projected terms and SQL terms. module Database.Relational.Projectable.Instances () where import Data.Functor.ProductIsomorphic (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), ProductIsoEmpty, pureE, peRight, peLeft, ) import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow) import qualified Database.Relational.Record as Record import Database.Relational.Projectable.Unsafe (SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..)) -- context -- | Unsafely make 'Record' from SQL terms. instance SqlContext Flat where unsafeProjectSqlTerms = Record.unsafeFromSqlTerms -- | Unsafely make 'Record' from SQL terms. instance SqlContext Aggregated where unsafeProjectSqlTerms = Record.unsafeFromSqlTerms -- | Unsafely make 'Record' from SQL terms. instance SqlContext OverWindow where unsafeProjectSqlTerms = Record.unsafeFromSqlTerms -- | full SQL expression is availabe in Flat context instance OperatorContext Flat -- | full SQL expression is availabe in Aggregated context instance OperatorContext Aggregated -- | 'Aggregated' context is aggregated context instance AggregatedContext Aggregated -- | 'OverWindow' context is aggregated context instance AggregatedContext OverWindow -- placeholders -- | Zipping except for identity element laws against placeholder parameter type. instance ProductIsoEmpty PlaceHolders () where pureE = PlaceHolders peRight _ = PlaceHolders peLeft _ = PlaceHolders -- | Compose seed of record type 'PlaceHolders'. instance ProductIsoFunctor PlaceHolders where _ |$| PlaceHolders = PlaceHolders -- | Compose record type 'PlaceHolders' using applicative style. instance ProductIsoApplicative PlaceHolders where pureP _ = PlaceHolders _pf |*| _pa = PlaceHolders relational-query-0.12.2.3/src/Database/Relational/Projectable/Unsafe.hs0000644000000000000000000000217113633172100024011 0ustar0000000000000000-- | -- Module : Database.Relational.Projectable.Unsafe -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides unsafe interfaces between projected terms and SQL terms. module Database.Relational.Projectable.Unsafe ( SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..) ) where import Database.Relational.Internal.String (StringSQL) import Database.Relational.SqlSyntax (Record) -- | Interface to project SQL terms unsafely. class SqlContext c where -- | Unsafely project from SQL expression terms. unsafeProjectSqlTerms :: [StringSQL] -> Record c t -- | Constraint to restrict context of full SQL expressions. -- For example, the expression at the left of OVER clause -- is not allowed using full SQL expression. class SqlContext c => OperatorContext c -- | Constraint to restrict context of aggregated SQL context. class AggregatedContext ac -- | Placeholder parameter type which has real parameter type arguemnt 'p'. data PlaceHolders p = PlaceHolders relational-query-0.12.2.3/src/Database/Relational/Pi/0000755000000000000000000000000013633172100020351 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/Pi/Unsafe.hs0000644000000000000000000001475513633172100022142 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Pi.Unsafe -- Copyright : 2013-2019 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.Pi.Unsafe ( -- * Projection path Pi, width', width, (<.>), (), (), pi, definePi, defineDirectPi', defineDirectPi, expandIndexes', expandIndexes, -- * Deprecated unsafeExpandIndexes', unsafeExpandIndexes ) where import Prelude hiding (pi, (.), id) import Control.Category (Category (..), (>>>)) import Data.Array (listArray, (!)) import Data.Functor.ProductIsomorphic (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), ProductIsoEmpty, pureE, peRight, peLeft, ) import Database.Record.Persistable (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, PersistableWidth (persistableWidth), maybeWidth) -- | 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'. newtype Pi r0 r1 = Pi { runPi :: PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1) } instance PersistableWidth r0 => Show (Pi r0 r1) where show p = unwords ["Pi", show $ unsafeExpandIndexes p] unsafePiAppend :: (PersistableRecordWidth b' -> PersistableRecordWidth b) -> (PersistableRecordWidth c' -> PersistableRecordWidth c) -> Pi a b' -> Pi b c' -> Pi a c unsafePiAppend wbf wcf (Pi f) (Pi g) = Pi $ \wa -> let (pab, wb) = f wa (pbc, wc) = g $ wbf wb in (pab `unsafePiAppend'` pbc, wcf wc) -- | Expand indexes from key. expandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int] expandIndexes' wa (Pi f) = d $ f wa where d (Map is, _) = is d (Leftest i, w) = [ i .. i + w' - 1 ] where w' = runPersistableRecordWidth w unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int] unsafeExpandIndexes' = expandIndexes' {-# DEPRECATED unsafeExpandIndexes' "Use expandIndexes' instead of this." #-} -- | Expand indexes from key. Infered width version. expandIndexes :: PersistableWidth a => Pi a b -> [Int] expandIndexes = expandIndexes' persistableWidth unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int] unsafeExpandIndexes = expandIndexes {-# DEPRECATED unsafeExpandIndexes "use expandIndexes instead of this." #-} -- | 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 f) = Pi $ \wa -> let (pb, wb) = f wa in (d pb, unsafeCastRecordWidth wb) -- | 'Pi' with zero width which projects to unit pzero :: Pi a () pzero = Pi $ \_ -> (Map [], persistableWidth) -- | Map projection path 'Pi' which has record result type. instance ProductIsoFunctor (Pi a) where _ |$| p = unsafeCast p -- | Compose projection path 'Pi' which has record result type using applicative style. instance ProductIsoApplicative (Pi a) where pureP _ = unsafeCast pzero pab |*| pb = Pi $ \wr -> let (_, wab) = runPi pab wr (_, wb) = runPi pb wr in (Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb, wab |*| wb) instance ProductIsoEmpty (Pi a) () where pureE = pzero peRight = unsafeCast peLeft = unsafeCast -- | Get record width proof object. width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct width' (Pi f) = snd $ f persistableWidth -- | Get record width. width :: PersistableWidth r => Pi r a -> Int width = runPersistableRecordWidth . width' justWidth :: PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a justWidth = unsafeCastRecordWidth instance Category Pi where id = Pi $ \pw -> (Leftest 0, pw) Pi fb . Pi fa = Pi $ \wa -> let (pb, wb) = fa wa (pc, wc) = fb wb in (unsafePiAppend' pb pc, wc) -- | Compose projection path. (<.>) :: Pi a b -> Pi b c -> Pi a c (<.>) = (>>>) -- | Compose projection path. 'Maybe' phantom functor is 'map'-ed. () :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c) () = unsafePiAppend justWidth maybeWidth -- | Compose projection path. 'Maybe' phantom functors are 'join'-ed like '>=>'. () :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c) () = unsafePiAppend justWidth id infixl 8 <.>, , -- | Unsafely project untyped value list. pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a] pi w0 (Pi f) cs = d p' where (p', w1) = f w0 d (Leftest i) = take (runPersistableRecordWidth w1) . 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.12.2.3/src/Database/Relational/InternalTH/0000755000000000000000000000000013633172100022011 5ustar0000000000000000relational-query-0.12.2.3/src/Database/Relational/InternalTH/Overloaded.hs0000644000000000000000000001056713633172100024442 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} -- | -- Module : Database.Relational.InternalTH.Overloaded -- Copyright : 2017-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines overloaded projection templates for internally using. module Database.Relational.InternalTH.Overloaded ( monomorphicProjection, polymorphicProjections, tupleProjection, definePrimaryHasProjection, ) where #if __GLASGOW_HASKELL__ >= 800 import Language.Haskell.TH (Name, mkName, Q, TypeQ, Dec, instanceD, funD, appT, tupleT, varT, litT, strTyLit, clause, normalB, listE) import Language.Haskell.TH.Compat.Constraint (classP) import Language.Haskell.TH.Lib.Extra (integralE) import Language.Haskell.TH.Name.CamelCase (ConName, conName, toVarExp, toTypeCon) import Data.List (foldl', inits) import Data.Array ((!)) import Database.Record.Persistable (PersistableWidth, persistableWidth, PersistableRecordWidth, runPersistableRecordWidth) import Database.Record.TH (columnOffsetsVarNameDefault) import Database.Relational.Pi.Unsafe (definePi) import Database.Relational.Constraint (unsafeDefineConstraintKey, projectionKey) import Database.Relational.OverloadedProjection (HasProjection (projection)) #else import Language.Haskell.TH (Name, mkName, Q, TypeQ, appT, tupleT, varT, Dec) import Language.Haskell.TH.Name.CamelCase (ConName) import Data.List (foldl') #endif -- | Projection template for monomorphic record type. monomorphicProjection :: ConName -> String -> Int -> TypeQ -> Q [Dec] #if __GLASGOW_HASKELL__ >= 800 monomorphicProjection recName colStr ix colType = [d| instance HasProjection $(litT $ strTyLit colStr) $(toTypeCon recName) $colType where projection _ = definePi $ $offsetsExp ! $(integralE ix) |] where offsetsExp = toVarExp . columnOffsetsVarNameDefault $ conName recName #else monomorphicProjection _ _ _ _ = [d| |] #endif -- | Projection templates for record type with type variable. polymorphicProjections :: TypeQ -> [Name] -> [String] -> [TypeQ] -> Q [Dec] #if __GLASGOW_HASKELL__ >= 800 polymorphicProjections recType avs sels cts = sequence $ zipWith3 template sels cts (inits cts) where template colStr colType pcts = instanceD (mapM (classP ''PersistableWidth . (:[]) . varT) avs) [t| HasProjection $(litT $ strTyLit colStr) $recType $colType |] [projectionDec pcts] projectionDec :: [TypeQ] -> Q Dec projectionDec cts = funD (mkName "projection") [clause [[p| _ |]] (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |]) []] --- In sub-tree, newName "projection" is called by [d| projection .. = |]? --- head <$> [d| projection _ = definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] cts) |] where runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |] #else polymorphicProjections _ _ _ _ = [d| |] #endif -- | Projection templates for tuple type. tupleProjection :: Int -> Q [Dec] tupleProjection n = do p <- polymorphicProjections tyRec avs ["fst", "snd"] cts q <- polymorphicProjections tyRec avs sels cts return $ p ++ q where sels = [ "pi" ++ show i | i <- [ 0 .. n - 1] ] ((avs, cts), tyRec) = tupleN tupleN :: (([Name], [TypeQ]), TypeQ) --- same as tupleN of InternalTH.Base, merge after dropping GHC 7.x tupleN = ((ns, vs), foldl' appT (tupleT n) vs) where ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ] vs = map varT ns -- | Projection template for primary key. definePrimaryHasProjection :: TypeQ -- ^ Record type -> TypeQ -- ^ Key type -> [Int] -- ^ Indexes specifies key -> Q [Dec] -- ^ Result 'HasProjection' declaration #if __GLASGOW_HASKELL__ >= 800 definePrimaryHasProjection recType colType indexes = [d| instance HasProjection "primary" $recType $colType where projection _ = projectionKey $ unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes]) |] #else definePrimaryHasProjection _ _ _ = [d| |] #endif relational-query-0.12.2.3/src/Database/Relational/InternalTH/Base.hs0000644000000000000000000000504013633172100023216 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} -- | -- Module : Database.Relational.InternalTH.Base -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines templates for internally using. module Database.Relational.InternalTH.Base ( defineTupleShowLiteralInstance, defineTuplePi, defineRecordProjections, ) where import Control.Applicative ((<$>)) import Data.List (foldl', inits) import Language.Haskell.TH (Q, Name, mkName, normalB, varP, TypeQ, forallT, varT, tupleT, appT, Dec, sigD, valD, instanceD, TyVarBndr (PlainTV), ) import Language.Haskell.TH.Compat.Constraint (classP) import Database.Record.Persistable (PersistableWidth, persistableWidth, PersistableRecordWidth, runPersistableRecordWidth) import Database.Relational.ProjectableClass (LiteralSQL (..)) import Database.Relational.Pi.Unsafe (Pi, definePi) tupleN :: Int -> (([Name], [TypeQ]), TypeQ) tupleN n = ((ns, vs), foldl' appT (tupleT n) vs) where ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ] vs = map varT ns -- | Make template of 'LiteralSQL' instance of tuple type. defineTupleShowLiteralInstance :: Int -> Q [Dec] defineTupleShowLiteralInstance n = do let ((_, vs), tty) = tupleN n (:[]) <$> instanceD -- in template-haskell 2.8 or older, Pred is not Type (mapM (classP ''LiteralSQL . (:[])) vs) [t| LiteralSQL $tty |] [] -- | Make polymorphic projection templates. defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec] defineRecordProjections tyRec avs sels cts = fmap concat . sequence $ zipWith3 template cts (inits cts) sels where template :: TypeQ -> [TypeQ] -> Name -> Q [Dec] template ct pcts selN = do sig <- sigD selN $ forallT (map PlainTV avs) (mapM (classP ''PersistableWidth . (:[]) . varT) avs) [t| Pi $tyRec $ct |] let runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |] val <- valD (varP selN) (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) :: Int |]) [| 0 :: Int |] pcts) |]) [] return [sig, val] -- | Make templates of projection paths for tuple types. defineTuplePi :: Int -> Q [Dec] defineTuplePi n = defineRecordProjections tyRec avs sels cts where ((avs, cts), tyRec) = tupleN n sels = [ mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'" | i <- [ 0 .. n - 1] ] relational-query-0.12.2.3/test/0000755000000000000000000000000013633172100014373 5ustar0000000000000000relational-query-0.12.2.3/test/Lex.hs0000644000000000000000000000776413633172100015475 0ustar0000000000000000module Lex (eqProp, 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 -> (a -> String) -> a -> String -> Test eqProp' name fstr x est = boolTest' name em (fstr x `eq` est) where em = unlines [show $ run $ fstr x, " -- compares --", show $ run est] eqProp :: Show a => String -> a -> String -> Test eqProp name = eqProp' name show relational-query-0.12.2.3/test/sqlsEqArrow.hs0000644000000000000000000004646313633172100017227 0ustar0000000000000000{-# LANGUAGE Arrows #-} import Test.QuickCheck.Simple (Test, defaultMain) import qualified Test.QuickCheck.Simple as QSimple import Lex (eqProp, eqProp') import Model import Control.Arrow (returnA, arr, (<<<), (***)) import Data.Int (Int32, Int64) import Data.Functor.ProductIsomorphic ((|$|), (|*|)) import Database.Relational.Arrow 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 $ proc () -> do a <- query setA -< () returnA -< a queryMaybeX :: Relation () (Maybe SetA) queryMaybeX = relation $ proc () -> do a <- queryMaybe setA -< () returnA -< a onX :: Relation () (Maybe SetA, SetB) onX = relation $ proc () -> do a <- queryMaybe setA -< () b <- query setB -< () on -< a ?! intA0' .=. just (b ! intB0') returnA -< (,) |$| a |*| b wheresX :: Relation () (SetA, SetB) wheresX = relation $ proc () -> do a <- query setA -< () b <- query setB -< () wheres -< b ! intB0' .>=. value 3 returnA -< (,) |$| a |*| b groupByX :: Relation () (Int32, Integer) groupByX = aggregateRelation $ proc () -> do a <- query setA -< () ga0 <- groupBy -< a ! intA0' returnA -< (,) |$| ga0 |*| count (a ! intA0') havingX :: Relation () Int havingX = aggregateRelation $ proc () -> do a <- query setA -< () let c = count (a ! intA0') having -< c .>. value 1 returnA -< c distinctX :: Relation () Int32 distinctX = relation $ proc () -> do distinct -< () a <- query setA -< () returnA -< a ! intA0' all'X :: Relation () Int32 all'X = relation $ proc () -> do all' -< () a <- query setA -< () returnA -< a ! intA0' assignX :: Update () assignX = updateNoPH $ proc _proj -> assign intA0' -< value (0 :: Int32) registerX :: Insert (String, Maybe String) registerX = insertValue $ proc () -> do assign intC0' -< value 1 (ph1, ()) <- placeholder -< proc ph' -> do assign strC1' -< ph' assign intC2' -< value 2 (ph2, ()) <- placeholder -< proc ph' -> do assign mayStrC3' -< ph' returnA -< ph1 >< ph2 eqChunkedInsert :: String -> Insert a -> String -> String -> Test eqChunkedInsert name ins prefix row = maybe (name, success) (\(sql, n) -> let estimate = unwords $ prefix : replicate (n - 1) (row ++ ",") ++ [row] in eqProp' name id sql estimate) $ chunkedInsert ins where success = QSimple.Bool Nothing True 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 T0 SET int_a0 = 0" , eqProp "insert" registerX "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES (1, ?, 2, ?)" , eqChunkedInsert "insert chunked" registerX "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES" "(1, ?, 2, ?)" ] _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 $ 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] nestedPiRec :: Relation () SetA nestedPiRec = relation $ proc () -> do ar <- (query . relation $ proc () -> do a <- query setA -< () returnA -< value "Hello" >< a) -< () returnA -< ar ! snd' nestedPiCol :: Relation () String nestedPiCol = relation $ proc () -> do ar <- (query . relation $ proc () -> do a <- query setA -< () returnA -< a >< value "Hello") -< () returnA -< ar ! snd' nestedPi :: Relation () String nestedPi = relation $ proc () -> do ar <- (query . relation $ proc () -> do a <- query setA -< () returnA -< (value "Hello" >< a) >< value "World") -< () returnA -< ar ! snd' nested :: [Test] nested = [ eqProp "nested pi record" nestedPiRec "SELECT ALL T1.f1 AS f0, T1.f2 AS f1, T1.f3 AS f2 \ \ FROM (SELECT ALL 'Hello' AS f0, \ \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3 \ \ FROM TEST.set_a T0) T1" , eqProp "nested pi column" nestedPiCol "SELECT ALL T1.f3 AS f0 \ \ FROM (SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ 'Hello' AS f3 \ \ FROM TEST.set_a T0) T1" , eqProp "nested pi both" nestedPi "SELECT ALL T1.f4 AS f0 \ \ FROM (SELECT ALL 'Hello' AS f0, \ \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3, \ \ 'World' AS f4 \ \ FROM TEST.set_a T0) T1" ] _p_nested :: IO () _p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] -- Record Operators bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> Relation () r bin53 op = relation $ proc () -> do returnA -< value 5 `op` value 3 strIn :: Relation () (Maybe Bool) strIn = relation $ proc () -> do returnA -< value "foo" `in'` values ["foo", "bar"] boolTF :: (Record Flat (Maybe Bool) -> Record Flat (Maybe Bool) -> Record Flat r) -> Relation () r boolTF op = relation $ proc () -> do returnA -< valueTrue `op` valueFalse 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_bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record 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" ] 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 NullsLast -< b ?! mayStrB1' returnA -< (,) |$| a |*| b ordFlatY :: Relation () (SetA, Maybe SetB) ordFlatY = relation $ proc () -> do a <- query setA -< () b <- queryMaybe setB -< () on -< just (a ! strA2') .=. b ?! strB2' orderBy Asc -< a ! strA1' orderBy' Desc NullsLast -< b returnA -< (,) |$| a |*| b ordAggX :: Relation () (String, Int64) ordAggX = aggregateRelation $ proc () -> do c <- query setC -< () gc1 <- groupBy -< c ! strC1' orderBy' Asc NullsFirst -< 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 NULLS LAST" , eqProp "order-by - flat 2" ordFlatY "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.int_b0 DESC NULLS LAST, \ \ T1.may_str_b1 DESC NULLS LAST, T1.str_b2 DESC NULLS LAST" , 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 NULLS FIRST" ] 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 = insert id' insertI :: Insert SetI insertI = insert id' insertQueryX :: InsertQuery () insertQueryX = insertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = updateNoPH $ proc proj -> do assign strA2' -< value "X" wheres -< proj ! strA1' .=. value "A" deleteX :: Delete () deleteX = deleteNoPH $ proc proj -> do wheres -< proj ! strA1' .=. value "A" 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 T0 SET str_a2 = 'X' WHERE (T0.str_a1 = 'A')" , eqProp "delete" deleteX "DELETE FROM TEST.set_a T0 WHERE (T0.str_a1 = 'A')" ] tests :: [Test] tests = concat [ tables, monadic, directJoins, join3s, nested, bin, maybes , groups, orders, partitions, exps, effs] main :: IO () main = defaultMain tests relational-query-0.12.2.3/test/sqlsEq.hs0000644000000000000000000006003013633172100016176 0ustar0000000000000000 import Test.QuickCheck.Simple (Test, defaultMain) import qualified Test.QuickCheck.Simple as QSimple import Lex (eqProp, eqProp') import Model import Control.Applicative ((<$>), (<*>)) import Data.Functor.ProductIsomorphic ((|$|), (|*|)) import Data.Int (Int32, Int64) import Database.Relational 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 = updateNoPH $ \_proj -> intA0' <-# value (0 :: Int32) registerX :: Insert (String, Maybe String) registerX = insertValue $ do intC0' <-# value 1 (ph1, ()) <- placeholder (\ph' -> strC1' <-# ph') intC2' <-# value 2 (ph2, ()) <- placeholder (\ph' -> mayStrC3' <-# ph') return $ ph1 >< ph2 eqChunkedInsert :: String -> Insert a -> String -> String -> Test eqChunkedInsert name ins prefix row = maybe (name, success) (\(sql, n) -> let estimate = unwords $ prefix : replicate (n - 1) (row ++ ",") ++ [row] in eqProp' name id sql estimate) $ chunkedInsert ins where success = QSimple.Bool Nothing True 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 T0 SET int_a0 = 0" , eqProp "insert" registerX "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES (1, ?, 2, ?)" , eqChunkedInsert "insert chunked" registerX "INSERT INTO TEST.set_c (int_c0, str_c1, int_c2, may_str_c3) VALUES" "(1, ?, 2, ?)" ] _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] -- Index of Nested Projections nestedPiRec :: Relation () SetA nestedPiRec = relation $ do ar <- query . relation $ do a <- query setA return $ value "Hello" >< a return $ ar ! snd' nestedPiCol :: Relation () String nestedPiCol = relation $ do ar <- query . relation $ do a <- query setA return $ a >< value "Hello" return $ ar ! snd' nestedPi :: Relation () String nestedPi = relation $ do ar <- query . relation $ do a <- query setA return $ (value "Hello" >< a) >< value "World" return $ ar ! snd' nested :: [Test] nested = [ eqProp "nested pi record" nestedPiRec "SELECT ALL T1.f1 AS f0, T1.f2 AS f1, T1.f3 AS f2 \ \ FROM (SELECT ALL 'Hello' AS f0, \ \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3 \ \ FROM TEST.set_a T0) T1" , eqProp "nested pi column" nestedPiCol "SELECT ALL T1.f3 AS f0 \ \ FROM (SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ 'Hello' AS f3 \ \ FROM TEST.set_a T0) T1" , eqProp "nested pi both" nestedPi "SELECT ALL T1.f4 AS f0 \ \ FROM (SELECT ALL 'Hello' AS f0, \ \ T0.int_a0 AS f1, T0.str_a1 AS f2, T0.str_a2 AS f3, \ \ 'World' AS f4 \ \ FROM TEST.set_a T0) T1" ] _p_nested :: IO () _p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] -- Record Operators bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record 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 :: (Record Flat (Maybe Bool) -> Record Flat (Maybe Bool) -> Record 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 :: (Record Flat Int32 -> Record Flat Int32 -> Record 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" ] caseSearchX :: Relation () String caseSearchX = relation $ do return $ caseSearch [ (value 2 .=. value (1 :: Int32) , value "foo") , (value 5 .=. value 3 .+. value (2 :: Int32) , value "bar") , (value "a" .=. value "b" , value "baz") ] (value "other") caseX :: Relation () String caseX = relation $ do return $ case' (value (5 :: Int32)) [ (value 1 , value "foo") , (value 3 .+. value 2 , value "bar") , (value 10 , value "baz") ] (value "other") caseRecordX :: Relation () Int32 caseRecordX = relation $ do return $ case' (value (5 :: Int32)) [ (value 1 , (,) |$| value 1 |*| value "foo") , (value 3 .+. value 2 , (,) |$| value 2 |*| value "bar") , (value 10 , (,) |$| value 3 |*| value "baz") ] ((,) |$| value (0 :: Int32) |*| value "other") ! fst' .*. value 10 caseRecordMaybeX :: Relation () (Maybe (Int32, String)) caseRecordMaybeX = relation $ do return $ caseMaybe (value (5 :: Int32)) [ (value (1 :: Int32) , just $ (,) |$| value (1 :: Int32) |*| value "foo") , (value 3 .+. value 2 , just $ (,) |$| value 2 |*| value "bar") ] cases :: [Test] cases = [ eqProp "caseSearch" caseSearchX "SELECT ALL CASE WHEN (2 = 1) THEN 'foo' WHEN (5 = (3 + 2)) THEN 'bar' WHEN ('a' = 'b') THEN 'baz' ELSE 'other' END AS f0" , eqProp "case" caseX "SELECT ALL CASE 5 WHEN 1 THEN 'foo' WHEN (3 + 2) THEN 'bar' WHEN 10 THEN 'baz' ELSE 'other' END AS f0" , eqProp "caseRecord" caseRecordX "SELECT ALL (CASE 5 WHEN 1 THEN 1 WHEN (3 + 2) THEN 2 WHEN 10 THEN 3 ELSE 0 END * 10) AS f0" , eqProp "caseRecordMaybe" caseRecordMaybeX "SELECT ALL CASE 5 WHEN 1 THEN 1 WHEN (3 + 2) THEN 2 ELSE NULL END AS f0, \ \ CASE 5 WHEN 1 THEN 'foo' WHEN (3 + 2) THEN 'bar' ELSE NULL END AS f1" ] _p_cases :: IO () _p_cases = mapM_ print [show caseSearchX, show caseX] nothingX :: Relation () (SetA, Maybe SetB) nothingX = relation $ do a <- query setA 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 maybeY :: Relation () (SetA, SetB) maybeY = relation $ do a <- queryMaybe setA b <- query setB wheres $ a ?! strA2' .=. b ! mayStrB1' return $ fromMaybe (SetA |$| value 1 |*| value "foo" |*| value "var") a >< 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 "fromMaybe record" maybeY "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, \ \ CASE WHEN (T0.int_a0 IS NULL) THEN 'foo' ELSE T0.str_a1 END AS f1, \ \ CASE WHEN (T0.int_a0 IS NULL) THEN 'var' ELSE T0.str_a2 END 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 (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 NullsLast return $ (,) |$| a |*| b ordFlatY :: Relation () (SetA, Maybe SetB) ordFlatY = relation $ do a <- query setA b <- queryMaybe setB on $ just (a ! strA2') .=. b ?! strB2' orderBy (a ! strA1') Asc orderBy' b Desc NullsLast return $ (,) |$| a |*| b ordAggX :: Relation () (String, Int64) ordAggX = aggregateRelation $ do c <- query setC gc1 <- groupBy $ c ! strC1' orderBy' (sum' $ c ! intC0') Asc NullsFirst 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 NULLS LAST" , eqProp "order-by - flag 2" ordFlatY "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.int_b0 DESC NULLS LAST, \ \ T1.may_str_b1 DESC NULLS LAST, T1.str_b2 DESC NULLS LAST" , 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 NULLS FIRST" ] 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 = insert id' insertI :: Insert SetI insertI = insert id' insertQueryX :: InsertQuery () insertQueryX = insertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = updateNoPH $ \proj -> do strA2' <-# value "X" wheres $ proj ! strA1' .=. value "A" deleteX :: Delete () deleteX = deleteNoPH $ \proj -> wheres $ proj ! strA1' .=. value "A" effs :: [Test] effs = [ eqProp "insert" insertX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)" , eqChunkedInsert "insert chunked" insertX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES" "(?, ?, ?)" , eqProp "insert1" insertI "INSERT INTO TEST.set_i (int_i0) VALUES (?)" , eqChunkedInsert "insert1 chunked" 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 T0 SET str_a2 = 'X' WHERE (T0.str_a1 = 'A')" , eqProp "delete" deleteX "DELETE FROM TEST.set_a T0 WHERE (T0.str_a1 = 'A')" ] updateExistsX :: Update () updateExistsX = updateNoPH $ \proj -> do strA2' <-# value "X" wheres . exists =<< (queryList . relation $ do b <- query setB wheres $ b ! intB0' .=. proj ! intA0' return b) updateScalarX :: Update () updateScalarX = updateNoPH $ \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 deleteExistsX :: Delete () deleteExistsX = deleteNoPH $ \proj -> wheres . exists =<< (queryList . relation $ do b <- query setB wheres $ b ! intB0' .=. proj ! intA0' return b) deleteScalarX :: Delete () deleteScalarX = deleteNoPH $ \proj -> do sb <- queryScalar . unsafeUnique . relation $ do b <- query setB wheres $ b ! intB0' .=. value 0 return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb correlated :: [Test] correlated = [ eqProp "update-exists" updateExistsX "UPDATE TEST.set_a T0 SET str_a2 = 'X' \ \ WHERE (EXISTS (SELECT ALL T1.int_b0 AS f0, T1.may_str_b1 AS f1, T1.str_b2 AS f2 \ \ FROM TEST.set_b T1 \ \ WHERE (T1.int_b0 = T0.int_a0)))" , eqProp "update-scalar" updateScalarX "UPDATE TEST.set_a T0 SET str_a2 = 'X' \ \ WHERE (T0.int_a0 = (SELECT ALL T1.int_b0 AS f0 \ \ FROM TEST.set_b T1 \ \ WHERE (T1.int_b0 = 0)))" , eqProp "delete-exists" deleteExistsX "DELETE FROM TEST.set_a T0 \ \ WHERE (EXISTS (SELECT ALL T1.int_b0 AS f0, T1.may_str_b1 AS f1, T1.str_b2 AS f2 \ \ FROM TEST.set_b T1 \ \ WHERE (T1.int_b0 = T0.int_a0)))" , eqProp "delete-scalar" deleteScalarX "DELETE FROM TEST.set_a T0 \ \ WHERE (T0.int_a0 = (SELECT ALL T1.int_b0 AS f0 \ \ FROM TEST.set_b T1 \ \ WHERE (T1.int_b0 = 0)))" ] tests :: [Test] tests = concat [ tables, monadic, directJoins, join3s, nested, bin, cases, uni , groups, orders, partitions, exps, effs, correlated] main :: IO () main = defaultMain tests relational-query-0.12.2.3/test/Model.hs0000644000000000000000000000263013633172100015770 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} module Model where import GHC.Generics (Generic) import Data.Int (Int32, Int64) import Database.Relational (defaultConfig) import Database.Relational.TH (defineTable, makeRelationalRecordDefault, defineScalarDegree) $(defineTable defaultConfig "TEST" "set_a" [ ("int_a0" , [t| Int32 |]) , ("str_a1" , [t| String |]) , ("str_a2" , [t| String |]) ] [''Generic] [0] $ Just 0) $(defineTable defaultConfig "TEST" "set_b" [ ("int_b0" , [t| Int32 |]) , ("may_str_b1" , [t| Maybe String |]) , ("str_b2" , [t| String |]) ] [''Generic] [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 |]) ] [''Generic] [0] $ Just 0) $(defineTable defaultConfig "TEST" "set_i" [ ("int_i0" , [t| Int32 |]) ] [''Generic] [0] $ Just 0) data ABC = ABC { xJustA :: SetA , xJustB :: SetB , xJustC :: SetC } deriving Generic $(makeRelationalRecordDefault ''ABC) data Abc = Abc { yJustA :: SetA , yMayB :: Maybe SetB , yMayC :: Maybe SetC } deriving Generic $(makeRelationalRecordDefault ''Abc) $(defineScalarDegree [t| Int32 |])