relational-query-0.9.5.1/0000755000000000000000000000000013206454105013347 5ustar0000000000000000relational-query-0.9.5.1/ChangeLog.md0000644000000000000000000000743013206454105015524 0ustar0000000000000000 ## 0.9.5.1 - add an upper bound of version constraint. ## 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.9.5.1/LICENSE0000644000000000000000000000275613206454105014366 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.9.5.1/Setup.hs0000644000000000000000000000005613206454105015004 0ustar0000000000000000import Distribution.Simple main = defaultMain relational-query-0.9.5.1/relational-query.cabal0000644000000000000000000001431113206454105017630 0ustar0000000000000000name: relational-query version: 0.9.5.1 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-2017 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.2.1 , 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.Query.Arrow Database.Relational.Query Database.Relational.Query.Table Database.Relational.Query.SQL Database.Relational.Query.Pure Database.Relational.Query.Pi Database.Relational.Query.Pi.Unsafe Database.Relational.Query.Constraint Database.Relational.Query.Context Database.Relational.Query.Component Database.Relational.Query.Sub Database.Relational.Query.Projection Database.Relational.Query.ProjectableClass Database.Relational.Query.Projectable Database.Relational.Query.ProjectableExtended Database.Relational.Query.TupleInstances Database.Relational.Query.Monad.BaseType Database.Relational.Query.Monad.Class Database.Relational.Query.Monad.Trans.Ordering Database.Relational.Query.Monad.Trans.Aggregating Database.Relational.Query.Monad.Trans.Restricting Database.Relational.Query.Monad.Trans.Join Database.Relational.Query.Monad.Trans.Config Database.Relational.Query.Monad.Trans.Assigning Database.Relational.Query.Monad.Type Database.Relational.Query.Monad.Simple Database.Relational.Query.Monad.Aggregate Database.Relational.Query.Monad.Unique Database.Relational.Query.Monad.Restrict Database.Relational.Query.Monad.Assign Database.Relational.Query.Monad.Register Database.Relational.Query.Relation Database.Relational.Query.Effect Database.Relational.Query.Scalar Database.Relational.Query.Type Database.Relational.Query.Derives Database.Relational.Query.BaseTH Database.Relational.Query.TH other-modules: Database.Relational.Query.Internal.Config Database.Relational.Query.Internal.ContextType Database.Relational.Query.Internal.SQL Database.Relational.Query.Internal.BaseSQL Database.Relational.Query.Internal.GroupingSQL Database.Relational.Query.Internal.UntypedTable Database.Relational.Query.Internal.Product Database.Relational.Query.Internal.Sub Database.Relational.Query.Monad.Trans.JoinState Database.Relational.Query.Monad.Trans.Qualify build-depends: base <5 , array , containers , transformers , time , time-locale-compat , bytestring , text , dlist , template-haskell , th-reify-compat , sql-words >=0.1.5 , names-th , persistable-record >= 0.5.1 && < 0.6 if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* hs-source-dirs: src ghc-options: -Wall -fsimpl-tick-factor=200 default-language: Haskell2010 test-suite sqls build-depends: base <5 , quickcheck-simple , 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 default-language: Haskell2010 test-suite sqlsArrow build-depends: base <5 , quickcheck-simple , 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 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.9.5.1/src/0000755000000000000000000000000013206454105014136 5ustar0000000000000000relational-query-0.9.5.1/src/Database/0000755000000000000000000000000013206454105015642 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/0000755000000000000000000000000013206454105017734 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/Query.hs0000644000000000000000000001004413206454105021374 0ustar0000000000000000-- | -- Module : Database.Relational.Query -- 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.Query ( module Database.Relational.Query.Table, module Database.Relational.Query.SQL, module Database.Relational.Query.Pi, module Database.Relational.Query.Constraint, module Database.Relational.Query.Context, module Database.Relational.Query.Component, module Database.Relational.Query.Sub, module Database.Relational.Query.Projection, module Database.Relational.Query.ProjectableClass, module Database.Relational.Query.Projectable, module Database.Relational.Query.ProjectableExtended, module Database.Relational.Query.TupleInstances, module Database.Relational.Query.Monad.BaseType, module Database.Relational.Query.Monad.Class, module Database.Relational.Query.Monad.Trans.Ordering, module Database.Relational.Query.Monad.Trans.Aggregating, module Database.Relational.Query.Monad.Trans.Assigning, module Database.Relational.Query.Monad.Type, module Database.Relational.Query.Monad.Simple, module Database.Relational.Query.Monad.Aggregate, module Database.Relational.Query.Monad.Restrict, module Database.Relational.Query.Monad.Unique, module Database.Relational.Query.Monad.Assign, module Database.Relational.Query.Monad.Register, module Database.Relational.Query.Relation, module Database.Relational.Query.Scalar, module Database.Relational.Query.Type, module Database.Relational.Query.Effect, module Database.Relational.Query.Derives ) where import Database.Relational.Query.Table (Table, TableDerivable (..)) import Database.Relational.Query.SQL (QuerySuffix, updateOtherThanKeySQL, insertSQL) import Database.Relational.Query.Pure () import Database.Relational.Query.Pi import Database.Relational.Query.Constraint (Key, tableConstraint, projectionKey, uniqueKey, -- notNullKey, HasConstraintKey(constraintKey), derivedUniqueKey, -- derivedNotNullKey, Primary, Unique, NotNull) import Database.Relational.Query.Context import Database.Relational.Query.Component (NameConfig (..), SchemaNameMode (..), ProductUnitSupport (..), IdentifierQuotation (..), Config (..), defaultConfig, AggregateKey, Order (..), Nulls (..)) import Database.Relational.Query.Sub (SubQuery, unitSQL, queryWidth) import Database.Relational.Query.Projection (Projection, list) import Database.Relational.Query.ProjectableClass import Database.Relational.Query.Projectable import Database.Relational.Query.ProjectableExtended import Database.Relational.Query.TupleInstances import Database.Relational.Query.Monad.BaseType import Database.Relational.Query.Monad.Class (MonadQualify, MonadRestrict, wheres, having, restrict, MonadAggregate, groupBy, groupBy', MonadQuery, query', queryMaybe', MonadPartition, partitionBy, distinct, all', on) import Database.Relational.Query.Monad.Trans.Ordering (orderBy', orderBy, asc, desc) import Database.Relational.Query.Monad.Trans.Aggregating (key, key', set, bkey, rollup, cube, groupingSets) import Database.Relational.Query.Monad.Trans.Assigning (assignTo, (<-#)) import Database.Relational.Query.Monad.Type import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery, Window, over) import Database.Relational.Query.Monad.Restrict (Restrict) import Database.Relational.Query.Monad.Unique (QueryUnique) import Database.Relational.Query.Monad.Assign (Assign) import Database.Relational.Query.Monad.Register (Register) import Database.Relational.Query.Relation import Database.Relational.Query.Scalar (ScalarDegree) import Database.Relational.Query.Type hiding (unsafeTypedKeyUpdate, unsafeTypedDelete, unsafeTypedInsert, unsafeTypedInsertQuery, ) import Database.Relational.Query.Effect import Database.Relational.Query.Derives import Database.Record.Instances () {-# ANN module "HLint: ignore Use import/export shortcut" #-} relational-query-0.9.5.1/src/Database/Relational/Query/0000755000000000000000000000000013206454105021041 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/Query/Component.hs0000644000000000000000000000156113206454105023342 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Component -- 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.Query.Component ( -- * Configuration type for query module Database.Relational.Query.Internal.Config, -- * Types for aggregation AggregateKey, -- * Types for ordering Order (..), Nulls (..), ) where import Database.Relational.Query.Internal.Config (NameConfig (..), ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), Config (..), defaultConfig,) import Database.Relational.Query.Internal.BaseSQL (Order (..), Nulls (..),) import Database.Relational.Query.Internal.GroupingSQL (AggregateKey) relational-query-0.9.5.1/src/Database/Relational/Query/Table.hs0000644000000000000000000000402113206454105022421 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Table -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines table type which has table metadatas. module Database.Relational.Query.Table ( -- * Phantom typed table type Table, unType, name, shortName, width, columns, index, table, toMaybe, recordWidth, -- * Table existence inference TableDerivable (..) ) where import Data.Array (listArray) import Database.Record.Persistable (PersistableWidth, PersistableRecordWidth, unsafePersistableRecordWidth) import Database.Relational.Query.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!)) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, ) -- | Phantom typed table type newtype Table r = Table Untyped -- | Untype table. unType :: Table t -> Untyped unType (Table u) = u -- | Name string of table in SQL name :: Table r -> String name = name' . unType -- | Not qualified name string of table in SQL shortName :: Table r -> String shortName = tail . dropWhile (/= '.') . name -- | Width of table width :: Table r -> Int width = width' . unType -- | Column name strings in SQL columns :: Table r -> [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 -- | 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.9.5.1/src/Database/Relational/Query/Constraint.hs0000644000000000000000000000774313206454105023534 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.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.Query.Constraint ( -- * Constraint Key proof object Key, indexes, unsafeDefineConstraintKey, tableConstraint, projectionKey, -- unsafeReturnKey, -- unsafeAppendConstraint, -- * Derivation rules uniqueKey, -- notNullKey, -- * Inference rules HasConstraintKey (..), derivedUniqueKey, -- derivedNotNullKey, -- * Constraint types Primary, Unique, NotNull ) where import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) import Database.Record.KeyConstraint (KeyConstraint, unsafeSpecifyKeyConstraint, Primary, Unique, NotNull) import qualified Database.Record.KeyConstraint as C import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi -- | Constraint Key proof object. Constraint type 'c', record type 'r' and columns type 'ct'. 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.9.5.1/src/Database/Relational/Query/SQL.hs0000644000000000000000000001006713206454105022040 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Query.SQL -- 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.Query.SQL ( -- * Query suffix QuerySuffix, showsQuerySuffix, -- * Update SQL updatePrefixSQL, updateSQL', updateOtherThanKeySQL', updateOtherThanKeySQL, -- * Insert SQL insertPrefixSQL, insertSQL, -- * Delete SQL deletePrefixSQL', deletePrefixSQL ) where import Data.Array (listArray, (!)) import Data.Monoid (mconcat, (<>)) import Language.SQL.Keyword (Keyword(..), (.=.), (|*|)) import qualified Language.SQL.Keyword as SQL import Database.Record (PersistableWidth) import Database.Record.ToSql (untypedUpdateValuesIndex) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL, rowConsStringSQL, ) import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Relational.Query.Table (Table, name, columns, recordWidth) import qualified Database.Relational.Query.Projection as Projection -- | Type for query suffix words type QuerySuffix = [Keyword] -- | Expand query suffix words showsQuerySuffix :: QuerySuffix -> StringSQL showsQuerySuffix = mconcat -- | Generate prefix string of update SQL. updatePrefixSQL :: Table r -> StringSQL updatePrefixSQL table = UPDATE <> stringSQL (name table) -- | Generate update SQL by specified key and table. -- Columns name list of table are also required. updateSQL' :: String -- ^ Table name -> [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) (UnsafePi.unsafeExpandIndexes' (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 = Projection.columns . Projection.wpi (recordWidth table) (Projection.unsafeFromTable table) $ pi' {-# DEPRECATED insertSQL "Deprecated." #-} -- | Generate insert SQL. insertSQL :: PersistableWidth r => Pi r r' -- ^ Columns selector to insert -> Table r -- ^ Table metadata -> String -- ^ Result SQL insertSQL pi' tbl = showStringSQL $ insertPrefixSQL pi' tbl <> VALUES <> vs where w = UnsafePi.width pi' vs = rowConsStringSQL (replicate w "?") -- | 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.9.5.1/src/Database/Relational/Query/Scalar.hs0000644000000000000000000000153613206454105022607 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.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.Query.Scalar ( -- * Single degree constraint ScalarDegree, defineScalarDegree ) where import Language.Haskell.TH (Q, TypeQ, Dec) import Database.Record (PersistableWidth) -- | Constraint which represents scalar degree. class PersistableWidth ct => ScalarDegree ct instance ScalarDegree ct => ScalarDegree (Maybe ct) -- | 'ScalarDegree' instance templates. defineScalarDegree :: TypeQ -> Q [Dec] defineScalarDegree typeCon = do [d| instance ScalarDegree $(typeCon) |] relational-query-0.9.5.1/src/Database/Relational/Query/TupleInstances.hs0000644000000000000000000000161413206454105024340 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Database.Relational.Query.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.Query.TupleInstances where import Control.Applicative ((<$>)) import Database.Relational.Query.BaseTH (defineTuplePi, defineTupleProductConstructor, defineTupleShowConstantInstance,) $(concat <$> mapM defineTupleProductConstructor [2..7]) $(concat <$> mapM defineTuplePi [2..7]) $(concat <$> mapM defineTupleShowConstantInstance [2..7]) -- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics. relational-query-0.9.5.1/src/Database/Relational/Query/Sub.hs0000644000000000000000000002773013206454105022137 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Query.Sub -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines sub-query structure used in query products. module Database.Relational.Query.Sub ( -- * Sub-query SubQuery, fromTable, flatSubQuery, aggregatedSubQuery, union, except, intersect, showSQL, toSQL, unitSQL, width, -- * Qualified Sub-query Qualifier (Qualifier), Qualified, queryWidth, -- * Sub-query columns column, -- * Projection Projection, ProjectionUnit, UntypedProjection, untypedProjectionFromJoinedSubQuery, projectionColumns, unsafeProjectionStringSql, -- * Product of sub-queries JoinProduct, NodeAttr (..), ProductBuilder, -- * Query restriction QueryRestriction, composeWhere, composeHaving ) where import Control.Applicative ((<$>)) import Data.Monoid (mempty, (<>), mconcat) import Data.Traversable (traverse) import Language.SQL.Keyword (Keyword(..), (|*|)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Query.Internal.Config (Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported)) import qualified Database.Relational.Query.Context as Context import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, rowStringSQL, showStringSQL, ) import Database.Relational.Query.Internal.BaseSQL (Duplication (..), showsDuplication, OrderingTerm, composeOrderBy, ) import Database.Relational.Query.Internal.GroupingSQL (AggregateElem, composeGroupBy, ) import Database.Relational.Query.Internal.Sub (SubQuery (..), Projection, CaseClause(..), WhenClauses (..), UntypedProjection, ProjectionUnit (..), JoinProduct, QueryProductTree, ProductBuilder, NodeAttr (Just', Maybe), ProductTree (Leaf, Join), SetOp (..), BinOp (..), Qualifier (..), Qualified (..), QueryRestriction) import qualified Database.Relational.Query.Internal.Sub as Internal import Database.Relational.Query.Internal.UntypedTable ((!)) import qualified Database.Relational.Query.Internal.UntypedTable as UntypedTable import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.ProjectableClass (showConstantTermsSQL) import Database.Relational.Query.Pure () showsSetOp' :: SetOp -> StringSQL showsSetOp' = d where d Union = UNION d Except = EXCEPT d Intersect = INTERSECT showsSetOp :: SetOp -> Duplication -> StringSQL showsSetOp op dup0 = showsSetOp' op <> mayDup dup0 where mayDup dup@All = showsDuplication dup mayDup Distinct = mempty -- | 'SubQuery' from 'Table'. fromTable :: Table r -- ^ Typed 'Table' metadata -> SubQuery -- ^ Result 'SubQuery' fromTable = Table . Table.unType -- | Unsafely generate flat 'SubQuery' from untyped components. flatSubQuery :: Config -> UntypedProjection -> Duplication -> JoinProduct -> QueryRestriction Context.Flat -> [OrderingTerm] -> SubQuery flatSubQuery = Flat -- | Unsafely generate aggregated 'SubQuery' from untyped components. aggregatedSubQuery :: Config -> UntypedProjection -> Duplication -> JoinProduct -> QueryRestriction Context.Flat -> [AggregateElem] -> QueryRestriction Context.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 -- | Width of 'SubQuery'. width :: SubQuery -> Int width = d where d (Table u) = UntypedTable.width' u d (Bin _ l _) = width l d (Flat _ up _ _ _ _) = Internal.untypedProjectionWidth up d (Aggregated _ up _ _ _ _ _ _) = Internal.untypedProjectionWidth up -- | SQL to query table. 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)..] -- | Normalized column SQL normalizedSQL :: SubQuery -> StringSQL normalizedSQL = d where d (Table t) = fromTableToNormalizedSQL t d sub@(Bin {}) = showUnitSQL sub d sub@(Flat _ _ _ _ _ ots) | null ots = showSQL sub | otherwise = showUnitSQL sub d sub@(Aggregated _ _ _ _ _ _ _ ots) | null ots = showSQL sub | otherwise = showUnitSQL sub selectPrefixSQL :: UntypedProjection -> Duplication -> StringSQL selectPrefixSQL up da = SELECT <> showsDuplication da <> SQL.fold (|*|) columns' where columns' = zipWith asColumnN (map columnOfProjectionUnit up) [(0 :: Int)..] -- | SQL string for nested-query and toplevel-SQL. toSQLs :: SubQuery -> (StringSQL, StringSQL) -- ^ sub-query SQL and top-level SQL toSQLs = d where d (Table u) = (stringSQL $ 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 columnN :: Int -> StringSQL columnN i = stringSQL $ 'f' : show i asColumnN :: StringSQL -> Int -> StringSQL c `asColumnN` n =c `SQL.as` columnN n -- | Alias string from qualifier showQualifier :: Qualifier -> StringSQL showQualifier (Qualifier i) = stringSQL $ 'T' : show i -- | Binary operator to qualify. (<.>) :: Qualifier -> StringSQL -> StringSQL i <.> n = showQualifier i SQL.<.> n -- | Qualified expression from qualifier and projection index. columnFromId :: Qualifier -> Int -> StringSQL columnFromId qi i = qi <.> columnN i -- | From 'Qualified' SQL string into qualified formed 'String' -- like (SELECT ...) AS T qualifiedSQLas :: Qualified StringSQL -> StringSQL qualifiedSQLas q = Internal.unQualify q <> showQualifier (Internal.qualifier q) -- | Width of 'Qualified' 'SubQUery'. queryWidth :: Qualified SubQuery -> Int queryWidth = width . Internal.unQualify -- | Get column SQL string of 'SubQuery'. column :: Qualified SubQuery -> Int -> StringSQL column qs = d (Internal.unQualify qs) where q = Internal.qualifier qs d (Table u) i = q <.> (u ! i) d (Bin {}) i = q `columnFromId` i d (Flat _ up _ _ _ _) i = columnOfUntypedProjection up i d (Aggregated _ up _ _ _ _ _ _) i = columnOfUntypedProjection up i -- | Make untyped projection from joined sub-query. untypedProjectionFromJoinedSubQuery :: Qualified SubQuery -> UntypedProjection untypedProjectionFromJoinedSubQuery qs = d $ Internal.unQualify qs where normalized = SubQueryRef <$> traverse (\q -> [0 .. width q - 1]) qs d (Table _) = map RawColumn . map (column qs) $ take (queryWidth qs) [0..] d (Bin {}) = normalized d (Flat {}) = normalized d (Aggregated {}) = normalized -- | index result of each when clause and else clause. indexWhensClause :: WhenClauses -> Int -> StringSQL indexWhensClause (WhenClauses ps e) i = mconcat [ when' p r | (p, r) <- ps] <> else' <> SQL.END where when' p r = SQL.WHEN <> rowStringSQL (map columnOfProjectionUnit p) <> SQL.THEN <> columnOfUntypedProjection r i else' = SQL.ELSE <> columnOfUntypedProjection e i -- | index result of each when clause and else clause. caseClause :: CaseClause -> Int -> StringSQL caseClause c i = d c where d (CaseSearch wcl) = SQL.CASE <> indexWhensClause wcl i d (CaseSimple m wcl) = SQL.CASE <> rowStringSQL (map columnOfProjectionUnit m) <> indexWhensClause wcl i -- | Convert from ProjectionUnit into column. columnOfProjectionUnit :: ProjectionUnit -> StringSQL columnOfProjectionUnit = d where d (RawColumn e) = e d (SubQueryRef qi) = Internal.qualifier qi `columnFromId` Internal.unQualify qi d (Scalar sub) = showUnitSQL sub d (Case c i) = caseClause c i -- | Get column SQL string of 'UntypedProjection'. columnOfUntypedProjection :: UntypedProjection -- ^ Source 'Projection' -> Int -- ^ Column index -> StringSQL -- ^ Result SQL string columnOfUntypedProjection up i | 0 <= i && i < Internal.untypedProjectionWidth up = columnOfProjectionUnit $ up !! i | otherwise = error $ "columnOfUntypedProjection: index out of bounds: " ++ show i -- | Get column SQL string list of projection. projectionColumns :: Projection c r -- ^ Source 'Projection' -> [StringSQL] -- ^ Result SQL string list projectionColumns = map columnOfProjectionUnit . Internal.untypeProjection -- | Unsafely get SQL term from 'Proejction'. unsafeProjectionStringSql :: Projection c r -> StringSQL unsafeProjectionStringSql = rowStringSQL . projectionColumns -- | Show product tree of query into SQL. StringSQL result. showsQueryProduct :: QueryProductTree -> StringSQL showsQueryProduct = rec where joinType Just' Just' = INNER joinType Just' Maybe = LEFT joinType Maybe Just' = RIGHT joinType Maybe Maybe = FULL urec n = case Internal.nodeTree n of p@(Leaf _) -> rec p p@(Join {}) -> SQL.paren (rec p) rec (Leaf q) = qualifiedSQLas $ fmap showUnitSQL q rec (Join left' right' rs) = mconcat [urec left', joinType (Internal.nodeAttr left') (Internal.nodeAttr right'), JOIN, urec right', ON, foldr1 SQL.and $ ps ++ concat [ showConstantTermsSQL True | null ps ] ] where ps = [ unsafeProjectionStringSql p | p <- rs ] -- | Shows join product of query. showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL showsJoinProduct ups = maybe (up ups) from where from qp = FROM <> showsQueryProduct qp up PUSupported = mempty up PUNotSupported = error "relation: Unit product support mode is disabled!" -- | Compose SQL String from 'QueryRestriction'. composeRestrict :: Keyword -> QueryRestriction c -> StringSQL composeRestrict k = d where d [] = mempty d ps@(_:_) = k <> foldr1 SQL.and [ unsafeProjectionStringSql p | p <- ps ] -- | Compose WHERE clause from 'QueryRestriction'. composeWhere :: QueryRestriction Context.Flat -> StringSQL composeWhere = composeRestrict WHERE -- | Compose HAVING clause from 'QueryRestriction'. composeHaving :: QueryRestriction Context.Aggregated -> StringSQL composeHaving = composeRestrict HAVING relational-query-0.9.5.1/src/Database/Relational/Query/TH.hs0000644000000000000000000005402213206454105021713 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ParallelListComp #-} -- | -- Module : Database.Relational.Query.TH -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines templates for Haskell record type and type class instances -- to define column projection on SQL query like Haskell records. -- Templates are generated by also using functions of "Database.Record.TH" module, -- so mapping between list of untyped SQL type and Haskell record type will be done too. module Database.Relational.Query.TH ( -- * All templates about table defineTable, -- * Inlining typed 'Query' unsafeInlineQuery, inlineQuery, -- * Column projections and basic 'Relation' for Haskell record defineTableTypesAndRecord, -- * Constraint key templates defineHasPrimaryKeyInstance, defineHasPrimaryKeyInstanceWithConfig, defineHasNotNullKeyInstance, defineHasNotNullKeyInstanceWithConfig, defineScalarDegree, -- * Column projections defineColumns, defineColumnsDefault, 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, -- * Add type class instance against record type defineProductConstructorInstance, -- * Reify makeRelationalRecordDefault, reifyRelation, ) where import Data.Char (toUpper, toLower) import Data.List (foldl1') import Data.Array.IArray ((!)) import Language.Haskell.TH (Name, nameBase, Q, reify, TypeQ, Type (AppT, ConT), ExpQ, tupleT, appT, Dec, stringE, listE) import Language.Haskell.TH.Compat.Reify (unVarI) import Language.Haskell.TH.Name.CamelCase (VarName, varName, ConName (ConName), conName, varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon) 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.Query (Table, Pi, id', Relation, ShowConstantTermsSQL, NameConfig (..), SchemaNameMode (..), IdentifierQuotation (..), Config (normalizedTableName, schemaNameMode, nameConfig, identifierQuotation), relationalQuerySQL, Query, relationalQuery, KeyUpdate, Insert, derivedInsert, InsertQuery, derivedInsertQuery, HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate) import Database.Relational.Query.BaseTH (defineProductConstructorInstance, defineTuplePi) import Database.Relational.Query.Scalar (defineScalarDegree) import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey) import Database.Relational.Query.Table (TableDerivable (..)) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Relation (derivedRelation) import Database.Relational.Query.SQL (QuerySuffix) import Database.Relational.Query.Type (unsafeTypedQuery) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi -- | Rule template to infer constraint key. defineHasConstraintKeyInstance :: TypeQ -- ^ Constraint type -> TypeQ -- ^ Record type -> TypeQ -- ^ Key type -> [Int] -- ^ Indexes specifies key -> Q [Dec] -- ^ Result 'HasConstraintKey' declaration defineHasConstraintKeyInstance constraint recType colType indexes = do -- kc <- defineHasColumnConstraintInstance constraint recType index ck <- [d| instance HasConstraintKey $constraint $recType $colType where constraintKey = unsafeDefineConstraintKey $(listE [integralE ix | ix <- indexes]) |] return ck -- | Rule template to infer primary key. defineHasPrimaryKeyInstance :: TypeQ -- ^ Record type -> TypeQ -- ^ Key type -> [Int] -- ^ Indexes specifies key -> Q [Dec] -- ^ Result constraint key declarations defineHasPrimaryKeyInstance recType colType indexes = do kc <- Record.defineHasPrimaryKeyInstance recType indexes ck <- defineHasConstraintKeyInstance [t| Primary |] recType colType indexes return $ kc ++ ck -- | Rule template to infer primary key. defineHasPrimaryKeyInstanceWithConfig :: Config -- ^ configuration parameters -> String -- ^ Schema name -> String -- ^ Table name -> TypeQ -- ^ Column type -> [Int] -- ^ Primary key index -> Q [Dec] -- ^ Declarations of primary constraint key defineHasPrimaryKeyInstanceWithConfig config scm = defineHasPrimaryKeyInstance . 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 -- | Column projection path 'Pi' template. columnTemplate' :: TypeQ -- ^ Record type -> VarName -- ^ Column declaration variable name -> ExpQ -- ^ Column index expression in record (begin with 0) -> TypeQ -- ^ Column type -> Q [Dec] -- ^ Column projection path declaration columnTemplate' recType var' iExp colType = do let var = varName var' simpleValD var [t| Pi $recType $colType |] [| UnsafePi.definePi $(iExp) |] -- | Column projection path 'Pi' and constraint key template. columnTemplate :: Maybe (TypeQ, VarName) -- ^ May Constraint type and constraint object name -> TypeQ -- ^ Record type -> VarName -- ^ Column declaration variable name -> ExpQ -- ^ Column index expression in record (begin with 0) -> TypeQ -- ^ Column type -> Q [Dec] -- ^ Column projection path declaration columnTemplate mayConstraint recType var' iExp colType = do col <- columnTemplate' recType var' iExp colType cr <- maybe (return []) ( \(constraint, cname') -> do simpleValD (varName cname') [t| Key $constraint $recType $colType |] [| unsafeDefineConstraintKey $(iExp) |] ) mayConstraint return $ col ++ cr -- | Column projection path 'Pi' templates. defineColumns :: ConName -- ^ Record type name -> [((VarName, TypeQ), Maybe (TypeQ, VarName))] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineColumns recTypeName cols = do let defC ((cn, ct), mayCon) ix = columnTemplate mayCon (toTypeCon recTypeName) cn [| $(toVarExp . columnOffsetsVarNameDefault $ conName recTypeName) ! $(integralE ix) |] ct fmap concat . sequence $ zipWith defC cols [0 :: Int ..] -- | Make column projection path and constraint key templates using default naming rule. defineColumnsDefault :: ConName -- ^ Record type name -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column info list -> Q [Dec] -- ^ Column projection path declarations defineColumnsDefault recTypeName cols = defineColumns recTypeName [((varN n, ct), fmap (withCName n) mayC) | ((n, ct), mayC) <- cols] where varN name = varCamelcaseName (name ++ "'") withCName name t = (t, varCamelcaseName ("constraint_key_" ++ name)) -- | Rule template to infer table derivations. defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec] defineTableDerivableInstance recordType' table columns = [d| instance TableDerivable $recordType' where derivedTable = Table.table $(stringE table) $(listE $ map stringE columns) |] -- | Template to define inferred entries from table type. defineTableDerivations :: VarName -- ^ Table declaration variable name -> VarName -- ^ Relation declaration variable name -> VarName -- ^ Insert statement declaration variable name -> VarName -- ^ InsertQuery statement declaration variable name -> TypeQ -- ^ Record type -> Q [Dec] -- ^ Table and Relation declaration defineTableDerivations tableVar' relVar' insVar' insQVar' recordType' = do let tableVar = varName tableVar' tableDs <- simpleValD tableVar [t| Table $recordType' |] [| derivedTable |] let relVar = varName relVar' relDs <- simpleValD relVar [t| Relation () $recordType' |] [| derivedRelation |] let insVar = varName insVar' insDs <- simpleValD insVar [t| Insert $recordType' |] [| derivedInsert id' |] let insQVar = varName insQVar' insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType' -> InsertQuery p |] [| derivedInsertQuery id' |] return $ concat [tableDs, relDs, insDs, insQDs] -- | 'Table' and 'Relation' templates. defineTableTypes :: VarName -- ^ Table declaration variable name -> VarName -- ^ Relation declaration variable name -> VarName -- ^ Insert statement declaration variable name -> VarName -- ^ InsertQuery statement declaration variable name -> TypeQ -- ^ Record type -> String -- ^ Table name in SQL ex. FOO_SCHEMA.table0 -> [String] -- ^ Column names -> Q [Dec] -- ^ Table and Relation declaration defineTableTypes tableVar' relVar' insVar' insQVar' recordType' table columns = do iDs <- defineTableDerivableInstance recordType' table columns dDs <- defineTableDerivations tableVar' relVar' insVar' insQVar' recordType' return $ iDs ++ dDs tableSQL :: Bool -> SchemaNameMode -> IdentifierQuotation -> String -> String -> String tableSQL normalize snm iq schema table = case snm of SchemaQualified -> (qt normalizeS) ++ '.' : (qt normalizeT) SchemaNotQualified -> (qt normalizeT) where normalizeS | normalize = map toUpper schema | otherwise = schema normalizeT | normalize = map toLower table | otherwise = table qt = quote iq quote :: IdentifierQuotation -> String -> String quote NoQuotation s = s quote (Quotation q) s = q : (escape s) ++ q : [] where escape = (>>= (\c -> if c == q then [q, q] else [c])) derivationVarNameDefault :: String -> VarName derivationVarNameDefault = (`varNameWithPrefix` "derivationFrom") -- | Make 'TableDerivation' variable expression template from table name using default naming rule. derivationExpDefault :: String -- ^ Table name string -> ExpQ -- ^ Result var Exp derivationExpDefault = toVarExp . derivationVarNameDefault tableVarNameDefault :: String -> VarName tableVarNameDefault = (`varNameWithPrefix` "tableOf") -- | Make 'Table' variable expression template from table name using default naming rule. tableVarExpDefault :: String -- ^ Table name string -> ExpQ -- ^ Result var Exp tableVarExpDefault = toVarExp . tableVarNameDefault -- | Make 'Relation' variable expression template from table name using specified naming rule. relationVarExp :: Config -- ^ Configuration which has naming rules of templates -> String -- ^ Schema name string -> String -- ^ Table name string -> ExpQ -- ^ Result var Exp relationVarExp config scm = toVarExp . relationVarName (nameConfig config) scm -- | Make template for record 'ProductConstructor' instance using specified naming rule. defineProductConstructorInstanceWithConfig :: Config -> String -> String -> [TypeQ] -> Q [Dec] defineProductConstructorInstanceWithConfig config schema table colTypes = do let tp = recordTemplate (recordConfig $ nameConfig config) schema table uncurry defineProductConstructorInstance tp colTypes -- | Make templates about table and column metadatas using specified naming rule. defineTableTypesWithConfig :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [((String, TypeQ), Maybe TypeQ)] -- ^ Column names and types and constraint type -> Q [Dec] -- ^ Result declarations defineTableTypesWithConfig config schema table columns = do let nmconfig = nameConfig config recConfig = recordConfig nmconfig tableDs <- defineTableTypes (tableVarNameDefault table) (relationVarName nmconfig schema table) (table `varNameWithPrefix` "insert") (table `varNameWithPrefix` "insertQuery") (fst $ recordTemplate recConfig schema table) (tableSQL (normalizedTableName config) (schemaNameMode config) (identifierQuotation config) schema table) (map ((quote (identifierQuotation config)) . fst . fst) columns) colsDs <- defineColumnsDefault (recordTypeName recConfig schema table) columns return $ tableDs ++ colsDs -- | 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 ShowConstantTermsSQL $(fst $ recordTemplate recConfig schema table) |] tableDs <- defineTableTypesWithConfig config schema table [(c, Nothing) | c <- 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 (primary $relE) |] -- | Template of derived primary 'Update'. definePrimaryUpdate :: VarName -- ^ Variable name of result declaration -> TypeQ -- ^ Parameter type of 'Update' -> TypeQ -- ^ Record type of 'Update' -> ExpQ -- ^ 'Table' expression -> Q [Dec] -- ^ Result 'Update' declaration definePrimaryUpdate toDef' paramType recType tableE = do let toDef = varName toDef' simpleValD toDef [t| KeyUpdate $paramType $recType |] [| primaryUpdate $tableE |] -- | SQL templates derived from primary key. defineSqlsWithPrimaryKey :: VarName -- ^ Variable name of select query definition from primary key -> VarName -- ^ Variable name of update statement definition from primary key -> TypeQ -- ^ Primary key type -> TypeQ -- ^ Record type -> ExpQ -- ^ Relation expression -> ExpQ -- ^ Table expression -> Q [Dec] -- ^ Result declarations defineSqlsWithPrimaryKey sel upd paramType recType relE tableE = do selD <- definePrimaryQuery sel paramType recType relE updD <- definePrimaryUpdate upd paramType recType tableE return $ selD ++ updD -- | SQL templates derived from primary key using default naming rule. defineSqlsWithPrimaryKeyDefault :: String -- ^ Table name of Database -> TypeQ -- ^ Primary key type -> TypeQ -- ^ Record type -> ExpQ -- ^ Relation expression -> ExpQ -- ^ Table expression -> Q [Dec] -- ^ Result declarations defineSqlsWithPrimaryKeyDefault table = defineSqlsWithPrimaryKey sel upd where sel = table `varNameWithPrefix` "select" upd = table `varNameWithPrefix` "update" -- | All templates about primary key. defineWithPrimaryKey :: Config -> String -- ^ Schema name -> String -- ^ Table name string -> TypeQ -- ^ Type of primary key -> [Int] -- ^ Indexes specifies primary key -> Q [Dec] -- ^ Result declarations defineWithPrimaryKey config schema table keyType ixs = do instD <- defineHasPrimaryKeyInstanceWithConfig config schema table keyType ixs let recType = 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) (relationalQuerySQL config rel sufs) (varCamelcaseName qns) -- | Generate all templates against defined record like type constructor -- other than depending on sql-value type. makeRelationalRecordDefault :: Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration makeRelationalRecordDefault recTypeName = do let recTypeConName = ConName recTypeName ((tyCon, dataCon), (mayNs, cts)) <- Record.reifyRecordType recTypeName pw <- Record.defineColumnOffsets recTypeConName cts cs <- maybe (return []) (\ns -> defineColumnsDefault recTypeConName [ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ]) mayNs pc <- defineProductConstructorInstance tyCon dataCon cts ct <- [d| instance ShowConstantTermsSQL $tyCon |] return $ concat [pw, cs, pc, ct] relational-query-0.9.5.1/src/Database/Relational/Query/ProjectableExtended.hs0000644000000000000000000001644713206454105025324 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.ProjectableExtended -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines operators on various polymorphic projections -- which needs extended GHC features. module Database.Relational.Query.ProjectableExtended ( -- * Projection for nested 'Maybe's ProjectableFlattenMaybe (flatten), flattenPiMaybe, -- * Get narrower projections (!), (?!), (?!?), (!??), -- * Aggregate functions unsafeAggregateOp, count, sum', sumMaybe, avg, avgMaybe, max', maxMaybe, min', minMaybe, every, any', some', -- * Zipping projection type trick ProjectableIdZip (leftId, rightId), ProjectableRunIdsZip (runIds), flattenPh -- generalizedZip', (>?<) ) where import Prelude hiding (pi) import qualified Language.SQL.Keyword as SQL import Database.Record (PersistableWidth) import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, unsafeUniOp, ProjectableMaybe (flattenMaybe), ProjectableIdZip (leftId, rightId), SqlProjectable) import Database.Relational.Query.Pi (Pi) class AggregatedContext ac instance AggregatedContext Aggregated instance AggregatedContext OverWindow -- | Unsafely make aggregation uni-operator from SQL keyword. unsafeAggregateOp :: (AggregatedContext ac, SqlProjectable (p ac)) => SQL.Keyword -> Projection Flat a -> p ac b unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren) -- | Aggregation function COUNT. count :: (Integral b, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac b count = unsafeAggregateOp SQL.COUNT -- | Aggregation function SUM. sumMaybe :: (Num a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe a) sumMaybe = unsafeAggregateOp SQL.SUM -- | Aggregation function SUM. sum' :: (Num a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe a) sum' = sumMaybe . Projection.just -- | Aggregation function AVG. avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe b) avgMaybe = unsafeAggregateOp SQL.AVG -- | Aggregation function AVG. avg :: (Num a, Fractional b, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe b) avg = avgMaybe . Projection.just -- | Aggregation function MAX. maxMaybe :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe a) maxMaybe = unsafeAggregateOp SQL.MAX -- | Aggregation function MAX. max' :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe a) max' = maxMaybe . Projection.just -- | Aggregation function MIN. minMaybe :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe a) -> p ac (Maybe a) minMaybe = unsafeAggregateOp SQL.MIN -- | Aggregation function MIN. min' :: (Ord a, AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat a -> p ac (Maybe a) min' = minMaybe . Projection.just -- | Aggregation function EVERY. every :: (AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) every = unsafeAggregateOp SQL.EVERY -- | Aggregation function ANY. any' :: (AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) any' = unsafeAggregateOp SQL.ANY -- | Aggregation function SOME. some' :: (AggregatedContext ac, SqlProjectable (p ac)) => Projection Flat (Maybe Bool) -> p ac (Maybe Bool) some' = unsafeAggregateOp SQL.SOME -- | Get narrower projection along with projection path. (!) :: PersistableWidth a => Projection c a -- ^ Source projection -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower projected object (!) = Projection.pi -- | Get narrower projection along with projection path -- 'Maybe' phantom functor is 'map'-ed. (?!) :: PersistableWidth a => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a b -- ^ Projection path -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result (?!) = Projection.piMaybe -- | Get narrower projection along with projection path -- and project into result projection type. -- Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed. (?!?) :: PersistableWidth a => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Projection c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result (?!?) = Projection.piMaybe' -- | Interface to compose phantom 'Maybe' nested type. class ProjectableFlattenMaybe a b where flatten :: ProjectableMaybe p => p a -> p b -- | Compose 'Maybe' type in projection phantom type. instance ProjectableFlattenMaybe (Maybe a) b => ProjectableFlattenMaybe (Maybe (Maybe a)) b where flatten = flatten . flattenMaybe -- | Not 'Maybe' type is not processed. instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where flatten = id -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path. flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Projection cont c -- ^ Narrower 'Projection'. Flatten 'Maybe' phantom type flattenPiMaybe p = flatten . Projection.piMaybe p -- | Get narrower projection with flatten leaf phantom Maybe types along with projection path. (!??) :: (PersistableWidth a, ProjectableMaybe (Projection cont), ProjectableFlattenMaybe (Maybe b) c) => Projection cont (Maybe a) -- ^ Source 'Projection'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Projection cont c -- ^ Narrower flatten and projected object. (!??) = flattenPiMaybe -- | Interface to run recursively identity element laws. class ProjectableRunIdsZip a b where runIds :: ProjectableIdZip p => p a -> p b -- | Run left identity element law. instance ProjectableRunIdsZip a b => ProjectableRunIdsZip ((), a) b where runIds = runIds . leftId -- | Run right identity element law. instance ProjectableRunIdsZip a b => ProjectableRunIdsZip (a, ()) b where runIds = runIds . rightId -- | Base case definition to run recursively identity element laws. instance ProjectableRunIdsZip a a where runIds = id -- | Specialize 'runIds' for 'PlaceHolders' type. flattenPh :: ProjectableRunIdsZip a b => PlaceHolders a -> PlaceHolders b flattenPh = runIds -- -- | Binary operator the same as 'generalizedZip'. -- (>?<) :: (ProjectableIdZip p, ProjectableRunIdsZip (a, b) c) -- => p a -> p b -> p c -- (>?<) = generalizedZip' infixl 8 !, ?!, ?!?, !?? -- infixl 1 >?< relational-query-0.9.5.1/src/Database/Relational/Query/Context.hs0000644000000000000000000000066313206454105023026 0ustar0000000000000000-- | -- Module : Database.Relational.Query.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.Query.Context ( module Database.Relational.Query.Internal.ContextType ) where import Database.Relational.Query.Internal.ContextType relational-query-0.9.5.1/src/Database/Relational/Query/Projection.hs0000644000000000000000000001636713206454105023526 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Projection -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines query projection type structure and interfaces. module Database.Relational.Query.Projection ( -- * Projection data structure and interface Projection, width, columns, untype, unsafeFromSqlTerms, unsafeFromQualifiedSubQuery, unsafeFromScalarSubQuery, unsafeFromTable, unsafeStringSql, -- * Projections pi, piMaybe, piMaybe', wpi, flattenMaybe, just, unsafeToAggregated, unsafeToFlat, unsafeChangeContext, unsafeStringSqlNotNullMaybe, pfmap, pap, -- * List Projection ListProjection, list, unsafeListFromSubQuery, unsafeStringSqlList ) where import Prelude hiding (pi) import qualified Language.SQL.Keyword as SQL import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint, PersistableWidth, persistableWidth) import Database.Record.Persistable (PersistableRecordWidth) import qualified Database.Record.KeyConstraint as KeyConstraint import Database.Relational.Query.Internal.SQL (StringSQL, listStringSQL, ) import Database.Relational.Query.Internal.Sub (SubQuery, Qualified, UntypedProjection, Projection, untypeProjection, typedProjection, projectionWidth) import qualified Database.Relational.Query.Internal.Sub as Internal import Database.Relational.Query.ProjectableClass (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), ) import Database.Relational.Query.Context (Aggregated, Flat) import Database.Relational.Query.Table (Table) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Pi (Pi) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Relational.Query.Sub (projectionColumns, untypedProjectionFromJoinedSubQuery, unsafeProjectionStringSql) import qualified Database.Relational.Query.Sub as SubQuery -- | Unsafely get SQL term from 'Proejction'. unsafeStringSql :: Projection c r -> StringSQL unsafeStringSql = unsafeProjectionStringSql -- | Get column SQL string list of projection. columns :: Projection c r -- ^ Source 'Projection' -> [StringSQL] -- ^ Result SQL string list columns = projectionColumns -- | Width of 'Projection'. width :: Projection c r -> Int width = projectionWidth -- | Unsafely get untyped projection. untype :: Projection c r -> UntypedProjection untype = untypeProjection -- | Unsafely generate 'Projection' from qualified (joined) sub-query. unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Projection c t unsafeFromQualifiedSubQuery = typedProjection . untypedProjectionFromJoinedSubQuery -- | Unsafely generate 'Projection' from scalar sub-query. unsafeFromScalarSubQuery :: SubQuery -> Projection c t unsafeFromScalarSubQuery = Internal.projectFromScalarSubQuery -- | Unsafely generate unqualified 'Projection' from 'Table'. unsafeFromTable :: Table r -> Projection c r unsafeFromTable = Internal.projectFromColumns . Table.columns -- | Unsafely generate 'Projection' from SQL expression strings. unsafeFromSqlTerms :: [StringSQL] -> Projection c t unsafeFromSqlTerms = Internal.projectFromColumns -- | Unsafely trace projection path. unsafeProject :: PersistableRecordWidth a -> Projection c a' -> Pi a b -> Projection c b' unsafeProject w p pi' = Internal.projectFromColumns . (UnsafePi.pi w pi') . columns $ p -- | Trace projection path to get narrower 'Projection'. wpi :: PersistableRecordWidth a -> Projection c a -- ^ Source 'Projection' -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower 'Projection' wpi = unsafeProject -- | Trace projection path to get narrower 'Projection'. pi :: PersistableWidth a => Projection c a -- ^ Source 'Projection' -> Pi a b -- ^ Projection path -> Projection c b -- ^ Narrower 'Projection' pi = unsafeProject persistableWidth -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. piMaybe :: PersistableWidth a => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a b -- ^ Projection path -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result piMaybe = unsafeProject persistableWidth -- | Trace projection path to get narrower 'Projection'. From 'Maybe' type to 'Maybe' type. -- Leaf type of projection path is 'Maybe'. piMaybe' :: PersistableWidth a => Projection c (Maybe a) -- ^ Source 'Projection'. 'Maybe' type -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf -> Projection c (Maybe b) -- ^ Narrower 'Projection'. 'Maybe' type result piMaybe' = unsafeProject persistableWidth unsafeCast :: Projection c r -> Projection c r' unsafeCast = typedProjection . untypeProjection -- | Composite nested 'Maybe' on projection phantom type. flattenMaybe :: Projection c (Maybe (Maybe a)) -> Projection c (Maybe a) flattenMaybe = unsafeCast -- | Cast into 'Maybe' on projection phantom type. just :: Projection c r -> Projection c (Maybe r) just = unsafeCast -- | Unsafely cast context type tag. unsafeChangeContext :: Projection c r -> Projection c' r unsafeChangeContext = typedProjection . untypeProjection -- | Unsafely lift to aggregated context. unsafeToAggregated :: Projection Flat r -> Projection Aggregated r unsafeToAggregated = unsafeChangeContext -- | Unsafely down to flat context. unsafeToFlat :: Projection Aggregated r -> Projection Flat r unsafeToFlat = unsafeChangeContext notNullMaybeConstraint :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> NotNullColumnConstraint r notNullMaybeConstraint = const KeyConstraint.columnConstraint -- | Unsafely get SQL string expression of not null key projection. unsafeStringSqlNotNullMaybe :: HasColumnConstraint NotNull r => Projection c (Maybe r) -> StringSQL unsafeStringSqlNotNullMaybe p = (!! KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p -- | Projectable fmap of 'Projection' type. pfmap :: ProductConstructor (a -> b) => (a -> b) -> Projection c a -> Projection c b _ `pfmap` p = unsafeCast p -- | Projectable ap of 'Projection' type. pap :: Projection c (a -> b) -> Projection c a -> Projection c b pf `pap` pa = typedProjection $ untypeProjection pf ++ untypeProjection pa -- | Compose seed of record type 'Projection'. instance ProjectableFunctor (Projection c) where (|$|) = pfmap -- | Compose record type 'Projection' using applicative style. instance ProjectableApplicative (Projection c) where (|*|) = pap -- | Projection type for row list. data ListProjection p t = List [p t] | Sub SubQuery -- | Make row list projection from 'Projection' list. list :: [p t] -> ListProjection p t list = List -- | Make row list projection from 'SubQuery'. unsafeListFromSubQuery :: SubQuery -> ListProjection p t unsafeListFromSubQuery = Sub -- | Map projection show operatoions and concatinate to single SQL expression. unsafeStringSqlList :: (p t -> StringSQL) -> ListProjection p t -> StringSQL unsafeStringSqlList sf = d where d (List ps) = listStringSQL $ map sf ps d (Sub sub) = SQL.paren $ SubQuery.showSQL sub relational-query-0.9.5.1/src/Database/Relational/Query/Derives.hs0000644000000000000000000001106113206454105022775 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.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.Query.Derives ( -- * Query derivation specifiedKey, unique, primary', primary, -- * Update derivation updateByConstraintKey, primaryUpdate, updateValuesWithKey, -- * Derived objects from table derivedUniqueRelation ) where import Database.Record (PersistableWidth, ToSql (recordToSql)) import Database.Record.ToSql (unsafeUpdateValuesWithIndexes) import Database.Relational.Query.Table (Table, TableDerivable) import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (placeholder, (.=.)) import Database.Relational.Query.ProjectableExtended ((!)) import Database.Relational.Query.Monad.Class (wheres) import Database.Relational.Query.Monad.BaseType (Relation, relationWidth) import Database.Relational.Query.Relation (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) import Database.Relational.Query.Constraint (Key, Primary, Unique, projectionKey, uniqueKey, HasConstraintKey(constraintKey)) import qualified Database.Relational.Query.Constraint as Constraint import Database.Relational.Query.Type (KeyUpdate, typedKeyUpdate) -- | Query restricted with specified key. specifiedKey :: PersistableWidth p => Pi a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'. -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' specifiedKey key rel = relation' $ do q <- query rel (param, ()) <- placeholder (\ph -> wheres $ Projection.wpi (relationWidth rel) q key .=. ph) return (param, q) -- | Query restricted with specified unique key. unique :: PersistableWidth p => Key Unique a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'. -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' unique = specifiedKey . projectionKey -- | Query restricted with specified primary key. primary' :: PersistableWidth p => Key Primary a p -- ^ Primary key proof object which record type is 'a' and key type is 'p'. -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' primary' = specifiedKey . projectionKey -- | Query restricted with inferred primary key. primary :: HasConstraintKey Primary a p => Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' primary = primary' constraintKey -- | Convert from Haskell type `r` into SQL value `q` list expected by update form like -- -- /UPDATE SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / -- -- using derived 'RecordToSql' proof object. updateValuesWithKey :: ToSql q r => Pi r p -> r -> [q] updateValuesWithKey = unsafeUpdateValuesWithIndexes recordToSql . unsafeExpandIndexes -- | Typed 'KeyUpdate' using specified constraint key. updateByConstraintKey :: Table r -- ^ 'Table' to update -> Key c r p -- ^ Key with constraint 'c', record type 'r' and columns type 'p' -> KeyUpdate p r -- ^ Result typed 'Update' updateByConstraintKey table' = typedKeyUpdate table' . Constraint.projectionKey -- | Typed 'KeyUpdate' using inferred primary key. primaryUpdate :: (HasConstraintKey Primary r p) => Table r -- ^ 'Table' to update -> KeyUpdate p r -- ^ Result typed 'Update' primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey) -- | 'UniqueRelation' inferred from table. derivedUniqueRelation :: TableDerivable r => Key Unique r k -- ^ Unique key proof object which record type is 'a' and key type is 'p'. -> Projection c k -- ^ Unique key value to specify. -> UniqueRelation () c r -- ^ Result restricted 'Relation' derivedUniqueRelation uk kp = unsafeUnique . relation $ do r <- query derivedRelation wheres $ r ! projectionKey uk .=. Projection.unsafeChangeContext kp return r relational-query-0.9.5.1/src/Database/Relational/Query/Pure.hs0000644000000000000000000001322213206454105022310 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Pure -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines interfaces between haskell pure values -- and query internal projection values. module Database.Relational.Query.Pure () where import Control.Applicative (pure) import Data.Monoid ((<>)) import Data.Int (Int8, Int16, Int32, Int64) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import Text.Printf (PrintfArg, printf) import Data.Time (FormatTime, Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, formatTime) import Data.Time.Locale.Compat (defaultTimeLocale) import Data.DList (DList, fromList) import Language.SQL.Keyword (Keyword (..)) import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL) import Database.Relational.Query.ProjectableClass (ShowConstantTermsSQL (..)) -- | Constant integral SQL terms. intTermsSQL :: (Show a, Integral a) => a -> DList StringSQL intTermsSQL = pure . stringSQL . show -- | Escape 'String' for constant SQL string expression. escapeStringToSqlExpr :: String -> String escapeStringToSqlExpr = rec where rec "" = "" rec ('\'':cs) = '\'' : '\'' : rec cs rec (c:cs) = c : rec cs -- | From 'String' into constant SQL string expression. stringExprSQL :: String -> StringSQL stringExprSQL = stringSQL . ('\'':) . (++ "'") . escapeStringToSqlExpr stringTermsSQL :: String -> DList StringSQL stringTermsSQL = pure . stringExprSQL -- | Constant SQL terms of '()'. instance ShowConstantTermsSQL () -- | Constant SQL terms of 'Int8'. instance ShowConstantTermsSQL Int8 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int16'. instance ShowConstantTermsSQL Int16 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int32'. instance ShowConstantTermsSQL Int32 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int64'. instance ShowConstantTermsSQL Int64 where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'Int'. -- Use this carefully, because this is architecture dependent size of integer type. instance ShowConstantTermsSQL Int where showConstantTermsSQL' = intTermsSQL -- | Constant SQL terms of 'String'. instance ShowConstantTermsSQL String where showConstantTermsSQL' = stringTermsSQL -- | Constant SQL terms of 'ByteString'. instance ShowConstantTermsSQL ByteString where showConstantTermsSQL' = stringTermsSQL . T.unpack . T.decodeUtf8 -- | Constant SQL terms of 'LB.ByteString'. instance ShowConstantTermsSQL LB.ByteString where showConstantTermsSQL' = stringTermsSQL . LT.unpack . LT.decodeUtf8 -- | Constant SQL terms of 'Text'. instance ShowConstantTermsSQL Text where showConstantTermsSQL' = stringTermsSQL . T.unpack -- | Constant SQL terms of 'LT.Text'. instance ShowConstantTermsSQL LT.Text where showConstantTermsSQL' = stringTermsSQL . LT.unpack -- | Constant SQL terms of 'Char'. instance ShowConstantTermsSQL Char where showConstantTermsSQL' = stringTermsSQL . (:"") -- | Constant SQL terms of 'Bool'. instance ShowConstantTermsSQL Bool where showConstantTermsSQL' = pure . stringSQL . d where d True = "(0=0)" d False = "(0=1)" 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 ShowConstantTermsSQL Float where showConstantTermsSQL' = floatTerms -- | Constant SQL terms of 'Double'. Caution for floating-point error rate. instance ShowConstantTermsSQL Double where showConstantTermsSQL' = floatTerms constantTimeTerms :: FormatTime t => Keyword -> String -> t -> DList StringSQL constantTimeTerms kw fmt t = pure $ kw <> stringExprSQL (formatTime defaultTimeLocale fmt t) -- | Constant SQL terms of 'Day'. instance ShowConstantTermsSQL Day where showConstantTermsSQL' = constantTimeTerms DATE "%Y-%m-%d" -- | Constant SQL terms of 'TimeOfDay'. instance ShowConstantTermsSQL TimeOfDay where showConstantTermsSQL' = constantTimeTerms TIME "%H:%M:%S" -- | Constant SQL terms of 'LocalTime'. instance ShowConstantTermsSQL LocalTime where showConstantTermsSQL' = constantTimeTerms TIMESTAMP "%Y-%m-%d %H:%M:%S" -- | Constant SQL terms of 'ZonedTime'. -- This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal. instance ShowConstantTermsSQL ZonedTime where showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z" -- | Constant SQL terms of 'UTCTime'. -- This generates ***NOT STANDARD*** SQL of TIMESTAMPTZ literal with UTC timezone. instance ShowConstantTermsSQL UTCTime where showConstantTermsSQL' = constantTimeTerms TIMESTAMPTZ "%Y-%m-%d %H:%M:%S%z" showMaybeTerms :: ShowConstantTermsSQL a => PersistableRecordWidth a -> Maybe a -> DList StringSQL showMaybeTerms wa = d where d (Just a) = showConstantTermsSQL' a d Nothing = fromList . replicate (runPersistableRecordWidth wa) $ stringSQL "NULL" -- | Constant SQL terms of 'Maybe' type. Width inference is required. instance (PersistableWidth a, ShowConstantTermsSQL a) => ShowConstantTermsSQL (Maybe a) where showConstantTermsSQL' = showMaybeTerms persistableWidth relational-query-0.9.5.1/src/Database/Relational/Query/Type.hs0000644000000000000000000003435713206454105022332 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Type -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed SQL. module Database.Relational.Query.Type ( -- * Typed query statement Query (..), unsafeTypedQuery, relationalQuery', relationalQuery, relationalQuerySQL, -- * Typed update statement KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, derivedKeyUpdate, Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate, typedUpdateAllColumn, derivedUpdateAllColumn', derivedUpdateAllColumn, restrictedUpdateAllColumn, restrictedUpdateTableAllColumn, updateSQL, -- * Typed insert statement Insert (..), untypeChunkInsert, chunkSizeOfInsert, unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert, typedInsertValue', typedInsertValue, derivedInsertValue', derivedInsertValue, InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', typedInsertQuery, derivedInsertQuery, insertQuerySQL, -- * Typed delete statement Delete (..), unsafeTypedDelete, typedDelete', typedDelete, derivedDelete', derivedDelete, deleteSQL, -- * Generalized interfaces UntypeableNoFetch (..) ) where import Data.Monoid ((<>)) import Database.Record (PersistableWidth) import Database.Relational.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (showStringSQL) import Database.Relational.Query.Monad.BaseType (Relation, sqlFromRelationWith) import Database.Relational.Query.Monad.Restrict (RestrictedStatement) import Database.Relational.Query.Monad.Assign (AssignStatement) import Database.Relational.Query.Monad.Register (Register) import Database.Relational.Query.Relation (tableOf) import Database.Relational.Query.Effect (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget', sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.SQL (QuerySuffix, showsQuerySuffix, insertPrefixSQL, updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL) -- | Query type with place-holder parameter 'p' and query result type 'a'. newtype Query p a = Query { untypeQuery :: String } -- | Unsafely make typed 'Query' from SQL string. unsafeTypedQuery :: String -- ^ Query SQL to type -> Query p a -- ^ Typed result unsafeTypedQuery = Query -- | Show query SQL string instance Show (Query p a) where show = untypeQuery -- | From 'Relation' into untyped SQL query string. relationalQuerySQL :: Config -> Relation p r -> QuerySuffix -> String relationalQuerySQL config rel qsuf = showStringSQL $ sqlFromRelationWith rel config <> showsQuerySuffix qsuf -- | From 'Relation' into typed 'Query' with suffix SQL words. relationalQuery' :: Relation p r -> QuerySuffix -> Query p r relationalQuery' rel qsuf = unsafeTypedQuery $ relationalQuerySQL defaultConfig rel qsuf -- | From 'Relation' into typed 'Query'. relationalQuery :: Relation p r -> Query p r relationalQuery = (`relationalQuery'` []) -- | Update type with key type 'p' and update record type 'a'. -- Columns to update are record columns other than key columns, -- So place-holder parameter type is the same as record type 'a'. data KeyUpdate p a = KeyUpdate { updateKey :: Pi a p , untypeKeyUpdate :: String } -- | Unsafely make typed 'KeyUpdate' from SQL string. unsafeTypedKeyUpdate :: Pi a p -> String -> KeyUpdate p a unsafeTypedKeyUpdate = KeyUpdate -- | Make typed 'KeyUpdate' from 'Table' and key columns selector 'Pi'. typedKeyUpdate :: Table a -> Pi a p -> KeyUpdate p a typedKeyUpdate tbl key = unsafeTypedKeyUpdate key $ updateOtherThanKeySQL tbl key -- | Make typed 'KeyUpdate' object using derived info specified by 'Relation' type. typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r typedKeyUpdateTable = typedKeyUpdate . tableOf -- derivedKeyUpdate' -- Config parameter is not yet required for KeyUpdate. -- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'. derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r derivedKeyUpdate = typedKeyUpdate derivedTable -- | Show update SQL string instance Show (KeyUpdate p a) where show = untypeKeyUpdate -- | Update type with place-holder parameter 'p'. newtype Update p = Update { untypeUpdate :: String } -- | Unsafely make typed 'Update' from SQL string. unsafeTypedUpdate :: String -> Update p unsafeTypedUpdate = Update -- | Make untyped update SQL string from 'Table' and 'UpdateTarget'. updateSQL :: Config -> Table r -> UpdateTarget p r -> String updateSQL config tbl ut = showStringSQL $ updatePrefixSQL tbl <> sqlFromUpdateTarget config tbl ut -- | Make typed 'Update' from 'Config', 'Table' and 'UpdateTarget'. typedUpdate' :: Config -> Table r -> UpdateTarget p r -> Update p typedUpdate' config tbl ut = unsafeTypedUpdate $ updateSQL config tbl ut -- | Make typed 'Update' using 'defaultConfig', 'Table' and 'UpdateTarget'. typedUpdate :: Table r -> UpdateTarget p r -> Update p typedUpdate = typedUpdate' defaultConfig targetTable :: TableDerivable r => UpdateTarget p r -> Table r targetTable = const derivedTable -- | Make typed 'Update' from 'Config', derived table and 'AssignStatement' derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p derivedUpdate' config utc = typedUpdate' config (targetTable ut) ut where ut = updateTarget' utc -- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement' derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p derivedUpdate = derivedUpdate' defaultConfig -- | Make typed 'Update' from 'Config', 'Table' and 'Restriction'. -- Update target is all column. typedUpdateAllColumn' :: PersistableWidth r => Config -> Table r -> Restriction p r -> Update (r, p) typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r -- | Make typed 'Update' from 'Table' and 'Restriction'. -- Update target is all column. typedUpdateAllColumn :: PersistableWidth r => Table r -> Restriction p r -> Update (r, p) typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r -- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'. -- Update target is all column. derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r) => Config -> RestrictedStatement r (PlaceHolders p) -> Update (r, p) derivedUpdateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction' -- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'. -- Update target is all column. derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r) => RestrictedStatement r (PlaceHolders p) -> Update (r, p) derivedUpdateAllColumn = derivedUpdateAllColumn' defaultConfig {-# DEPRECATED restrictedUpdateAllColumn "Use derivedUpdateAllColumn or typedUpdateAllColumn instead of this." #-} -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. -- Update target is all column. restrictedUpdateAllColumn :: PersistableWidth r => Table r -> RestrictedStatement r (PlaceHolders p) -- ^ 'Restrict' monad context -> Update (r, p) restrictedUpdateAllColumn tbl = typedUpdateAllColumn tbl . restriction' {-# DEPRECATED restrictedUpdateTableAllColumn "Use derivedUpdateAllColumn or typedUpdateAllColumn instead of this." #-} -- | Directly make typed 'Update' from 'Table' and 'Restrict' monad context. -- Update target is all column. restrictedUpdateTableAllColumn :: (PersistableWidth r, TableDerivable r) => Relation () r -> RestrictedStatement r (PlaceHolders p) -> Update (r, p) restrictedUpdateTableAllColumn = restrictedUpdateAllColumn . tableOf -- | Show update SQL string instance Show (Update p) where show = untypeUpdate -- | Insert type to insert record type 'a'. data Insert a = Insert { untypeInsert :: String , chunkedInsert :: Maybe (String, Int) } -- | Statement to use chunked insert untypeChunkInsert :: Insert a -> String untypeChunkInsert ins = maybe (untypeInsert ins) fst $ chunkedInsert ins -- | Size to use chunked insert chunkSizeOfInsert :: Insert a -> Int chunkSizeOfInsert = maybe 1 snd . chunkedInsert -- | Unsafely make typed 'Insert' from single insert and chunked insert SQL. unsafeTypedInsert' :: String -> String -> Int -> Insert a unsafeTypedInsert' s = curry (Insert s . Just) -- | Unsafely make typed 'Insert' from single insert SQL. unsafeTypedInsert :: String -> Insert a unsafeTypedInsert s = Insert s Nothing -- | Make typed 'Insert' from 'Table' and columns selector 'Pi' with configuration parameter. typedInsert' :: PersistableWidth r => Config -> Table r -> Pi r r' -> Insert r' typedInsert' config tbl = typedInsertValue' config tbl . insertTarget' . piRegister -- | 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'. derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' derivedInsert = typedInsert derivedTable -- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p typedInsertValue' config tbl it = unsafeTypedInsert' (showStringSQL $ sqlFromInsertTarget config tbl it) (showStringSQL ci) n where (ci, n) = sqlChunkFromInsertTarget config tbl it -- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object. typedInsertValue :: Table r -> InsertTarget p r -> Insert p typedInsertValue = typedInsertValue' defaultConfig -- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p derivedInsertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs where rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r rt = const derivedTable -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p derivedInsertValue = derivedInsertValue' defaultConfig -- | Show insert SQL string. instance Show (Insert a) where show = untypeInsert -- | InsertQuery type. newtype InsertQuery p = InsertQuery { untypeInsertQuery :: String } -- | Unsafely make typed 'InsertQuery' from SQL string. unsafeTypedInsertQuery :: String -> InsertQuery p unsafeTypedInsertQuery = InsertQuery -- | Make untyped insert select SQL string from 'Table', 'Pi' and 'Relation'. insertQuerySQL :: Config -> Table r -> Pi r r' -> Relation p r' -> String insertQuerySQL config tbl pi' rel = showStringSQL $ insertPrefixSQL pi' tbl <> sqlFromRelationWith rel config -- | Make typed 'InsertQuery' from columns selector 'Table', 'Pi' and 'Relation' with configuration parameter. typedInsertQuery' :: Config -> Table r -> Pi r r' -> Relation p r' -> InsertQuery p typedInsertQuery' config tbl pi' rel = unsafeTypedInsertQuery $ insertQuerySQL config tbl pi' rel -- | Make typed 'InsertQuery' from columns selector 'Table', 'Pi' and 'Relation'. typedInsertQuery :: Table r -> Pi r r' -> Relation p r' -> InsertQuery p typedInsertQuery = typedInsertQuery' defaultConfig -- | Table type inferred 'InsertQuery'. derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p derivedInsertQuery = typedInsertQuery derivedTable -- | Show insert SQL string. instance Show (InsertQuery p) where show = untypeInsertQuery -- | Delete type with place-holder parameter 'p'. newtype Delete p = Delete { untypeDelete :: String } -- | Unsafely make typed 'Delete' from SQL string. unsafeTypedDelete :: String -> Delete p unsafeTypedDelete = Delete -- | Make untyped delete SQL string from 'Table' and 'Restriction'. deleteSQL :: Config -> Table r -> Restriction p r -> String deleteSQL config tbl r = showStringSQL $ deletePrefixSQL tbl <> sqlWhereFromRestriction config tbl r -- | Make typed 'Delete' from 'Config', 'Table' and 'Restriction'. typedDelete' :: Config -> Table r -> Restriction p r -> Delete p typedDelete' config tbl r = unsafeTypedDelete $ deleteSQL config tbl r -- | Make typed 'Delete' from 'Table' and 'Restriction'. typedDelete :: Table r -> Restriction p r -> Delete p typedDelete = typedDelete' defaultConfig restrictedTable :: TableDerivable r => Restriction p r -> Table r restrictedTable = const derivedTable -- | Make typed 'Delete' from 'Config', derived table and 'RestrictContext' derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete' config rc = typedDelete' config (restrictedTable rs) rs where rs = restriction' rc -- | Make typed 'Delete' from 'defaultConfig', derived table and 'RestrictContext' derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete = derivedDelete' defaultConfig -- | Show delete SQL string instance Show (Delete p) where show = untypeDelete -- | Untype interface for typed no-result type statments -- with single type parameter which represents place-holder parameter 'p'. class UntypeableNoFetch s where untypeNoFetch :: s p -> String instance UntypeableNoFetch Insert where untypeNoFetch = untypeInsert instance UntypeableNoFetch InsertQuery where untypeNoFetch = untypeInsertQuery instance UntypeableNoFetch Update where untypeNoFetch = untypeUpdate instance UntypeableNoFetch Delete where untypeNoFetch = untypeDelete relational-query-0.9.5.1/src/Database/Relational/Query/Relation.hs0000644000000000000000000003462613206454105023165 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Relation -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines re-usable Relation type -- to compose complex query. module Database.Relational.Query.Relation ( -- * Relation type table, derivedRelation, tableOf, relation, relation', aggregateRelation, aggregateRelation', UniqueRelation, unsafeUnique, unUnique, uniqueRelation', aggregatedUnique, -- * Query using relation query, queryMaybe, queryList, queryList', queryScalar, queryScalar', uniqueQuery', uniqueQueryMaybe', -- * Direct style join JoinRestriction, inner', left', right', full', inner, left, right, full, on', -- * Relation append union, except, intersect, unionAll, exceptAll, intersectAll, union', except', intersect', unionAll', exceptAll', intersectAll', ) where import Control.Applicative ((<$>)) import Database.Relational.Query.Internal.BaseSQL (Duplication (Distinct, All)) import Database.Relational.Query.Context (Flat, Aggregated) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, unsafeTypeRelation, untypeRelation, relationWidth) import Database.Relational.Query.Monad.Class (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), on) import Database.Relational.Query.Monad.Simple (QuerySimple, SimpleQuery) import qualified Database.Relational.Query.Monad.Simple as Simple import Database.Relational.Query.Monad.Aggregate (QueryAggregate, AggregatedQuery) import qualified Database.Relational.Query.Monad.Aggregate as Aggregate import Database.Relational.Query.Monad.Unique (QueryUnique, unsafeUniqueSubQuery) import qualified Database.Relational.Query.Monad.Unique as Unique import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import Database.Relational.Query.Sub (SubQuery, NodeAttr(Just', Maybe)) import qualified Database.Relational.Query.Sub as SubQuery import Database.Relational.Query.Scalar (ScalarDegree) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Projection (Projection, ListProjection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, projectZip) -- | Simple 'Relation' from 'Table'. table :: Table r -> Relation () r table = unsafeTypeRelation . return . SubQuery.fromTable -- | 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 (Projection Flat r) query = fmap snd . query' -- | Join sub-query. Query result is 'Maybe'. -- The combinations of 'query' and 'queryMaybe' express -- inner joins, left outer joins, right outer joins, and full outer joins. -- Here is an example of a right outer join: -- -- @ -- outerJoin = relation $ do -- e <- queryMaybe employee -- d <- query department -- on $ e ?! E.deptId' .=. just (d ! D.deptId') -- return $ (,) |$| e |*| d -- @ queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> m (Projection Flat (Maybe r)) queryMaybe = fmap snd . queryMaybe' queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (ListProjection (Projection c) r) queryList0 = liftQualify . fmap Projection.unsafeListFromSubQuery . untypeRelation -- | List sub-query, for /IN/ and /EXIST/ with place-holder parameter 'p'. queryList' :: MonadQualify ConfigureQuery m => Relation p r -> m (PlaceHolders p, ListProjection (Projection c) r) queryList' rel = do ql <- queryList0 rel return (placeHoldersFromRelation rel, ql) -- | List sub-query, for /IN/ and /EXIST/. queryList :: MonadQualify ConfigureQuery m => Relation () r -> m (ListProjection (Projection c) r) queryList = queryList0 addUnitPH :: Functor f => f t -> f (PlaceHolders (), t) addUnitPH = ((,) unitPlaceHolder <$>) -- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'. relation' :: SimpleQuery p r -> Relation p r relation' = unsafeTypeRelation . Simple.toSubQuery -- | Finalize 'QuerySimple' monad and generate 'Relation'. relation :: QuerySimple (Projection Flat r) -> Relation () r relation = relation' . addUnitPH -- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'. aggregateRelation' :: AggregatedQuery p r -> Relation p r aggregateRelation' = unsafeTypeRelation . Aggregate.toSubQuery -- | Finalize 'QueryAggregate' monad and geneate 'Relation'. aggregateRelation :: QueryAggregate (Projection Aggregated r) -> Relation () r aggregateRelation = aggregateRelation' . addUnitPH -- | Restriction predicate function type for direct style join operator, -- used on predicates of direct join style as follows. -- -- @ -- do xy <- query $ -- relX `inner` relY `on'` [ \x y -> ... ] -- this lambda form has JoinRestriction type -- ... -- @ type JoinRestriction a b = Projection Flat a -> Projection Flat b -> Projection Flat (Maybe Bool) -- | Basic direct join operation with place-holder parameters. join' :: (qa -> QuerySimple (PlaceHolders pa, Projection Flat a)) -> (qb -> QuerySimple (PlaceHolders pb, Projection Flat b)) -> qa -> qb -> [JoinRestriction a b] -> Relation (pa, pb) (a, b) join' qL qR r0 r1 rs = relation' $ do (ph0, pj0) <- qL r0 (ph1, pj1) <- qR r1 sequence_ [ on $ f pj0 pj1 | f <- rs ] return (ph0 `projectZip` ph1, pj0 `projectZip` pj1) -- | Direct inner join with place-holder parameters. inner' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction a b] -- ^ Join restrictions -> Relation (pa, pb) (a, b) -- ^ Result joined relation inner' = join' query' query' -- | Direct left outer join with place-holder parameters. left' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions -> Relation (pa, pb) (a, Maybe b) -- ^ Result joined relation left' = join' query' queryMaybe' -- | Direct right outer join with place-holder parameters. right' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions -> Relation (pa, pb)(Maybe a, b) -- ^ Result joined relation right' = join' queryMaybe' query' -- | Direct full outer join with place-holder parameters. full' :: Relation pa a -- ^ Left query to join -> Relation pb b -- ^ Right query to join -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions -> Relation (pa, pb) (Maybe a, Maybe b) -- ^ Result joined relation full' = join' queryMaybe' queryMaybe' -- | Basic direct join operation. join_ :: (qa -> QuerySimple (Projection Flat a)) -> (qb -> QuerySimple (Projection Flat b)) -> qa -> qb -> [JoinRestriction a b] -> Relation () (a, b) join_ qL qR r0 r1 rs = relation $ do pj0 <- qL r0 pj1 <- qR r1 sequence_ [ on $ f pj0 pj1 | f <- rs ] return $ pj0 `projectZip` pj1 -- | Direct inner join. inner :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction a b] -- ^ Join restrictions -> Relation () (a, b) -- ^ Result joined relation inner = join_ query query -- | Direct left outer join. left :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions -> Relation () (a, Maybe b) -- ^ Result joined relation left = join_ query queryMaybe -- | Direct right outer join. right :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions -> Relation () (Maybe a, b) -- ^ Result joined relation right = join_ queryMaybe query -- | Direct full outer join. full :: Relation () a -- ^ Left query to join -> Relation () b -- ^ Right query to join -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions -> Relation () (Maybe a, Maybe b) -- ^ Result joined relation full = join_ queryMaybe queryMaybe -- | Apply restriction for direct join style. on' :: ([JoinRestriction a b] -> Relation pc (a, b)) -> [JoinRestriction a b] -> Relation pc (a, b) on' = ($) infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'` unsafeLiftAppend :: (SubQuery -> SubQuery -> SubQuery) -> Relation p a -> Relation q a -> Relation r a unsafeLiftAppend op a0 a1 = unsafeTypeRelation $ do s0 <- untypeRelation a0 s1 <- untypeRelation a1 return $ s0 `op` s1 liftAppend :: (SubQuery -> SubQuery -> SubQuery) -> Relation () a -> Relation () a -> Relation () a liftAppend = unsafeLiftAppend -- | Union of two relations. union :: Relation () a -> Relation () a -> Relation () a union = liftAppend $ SubQuery.union Distinct -- | Union of two relations. Not distinct. unionAll :: Relation () a -> Relation () a -> Relation () a unionAll = liftAppend $ SubQuery.union All -- | Subtraction of two relations. except :: Relation () a -> Relation () a -> Relation () a except = liftAppend $ SubQuery.except Distinct -- | Subtraction of two relations. Not distinct. exceptAll :: Relation () a -> Relation () a -> Relation () a exceptAll = liftAppend $ SubQuery.except All -- | Intersection of two relations. intersect :: Relation () a -> Relation () a -> Relation () a intersect = liftAppend $ SubQuery.intersect Distinct -- | Intersection of two relations. Not distinct. intersectAll :: Relation () a -> Relation () a -> Relation () a intersectAll = liftAppend $ SubQuery.intersect All liftAppend' :: (SubQuery -> SubQuery -> SubQuery) -> Relation p a -> Relation q a -> Relation (p, q) a liftAppend' = unsafeLiftAppend -- | Union of two relations with place-holder parameters. union' :: Relation p a -> Relation q a -> Relation (p, q) a union' = liftAppend' $ SubQuery.union Distinct -- | Union of two relations with place-holder parameters. Not distinct. unionAll' :: Relation p a -> Relation q a -> Relation (p, q) a unionAll' = liftAppend' $ SubQuery.union All -- | Subtraction of two relations with place-holder parameters. except' :: Relation p a -> Relation q a -> Relation (p, q) a except' = liftAppend' $ SubQuery.except Distinct -- | Subtraction of two relations with place-holder parameters. Not distinct. exceptAll' :: Relation p a -> Relation q a -> Relation (p, q) a exceptAll' = liftAppend' $ SubQuery.except All -- | Intersection of two relations with place-holder parameters. intersect' :: Relation p a -> Relation q a -> Relation (p, q) a intersect' = liftAppend' $ SubQuery.intersect Distinct -- | Intersection of two relations with place-holder parameters. Not distinct. intersectAll' :: Relation p a -> Relation q a -> Relation (p, q) a intersectAll' = liftAppend' $ SubQuery.intersect All infixl 7 `union`, `except`, `unionAll`, `exceptAll` infixl 8 `intersect`, `intersectAll` infixl 7 `union'`, `except'`, `unionAll'`, `exceptAll'` infixl 8 `intersect'`, `intersectAll'` {- -- | Get projection width from 'Relation'. width :: Relation p r -> Int width = SubQuery.width . subQueryFromRelation -} -- | Unique relation type to compose scalar queries. newtype UniqueRelation p c r = Unique (Relation p r) -- | Unsafely specify unique relation. unsafeUnique :: Relation p r -> UniqueRelation p c r unsafeUnique = Unique -- | Discard unique attribute. unUnique :: UniqueRelation p c r -> Relation p r unUnique (Unique r) = r -- | Basic monadic join operation using 'MonadQuery'. uniqueQueryWithAttr :: NodeAttr -> UniqueRelation p c r -> QueryUnique (PlaceHolders p, Projection c r) uniqueQueryWithAttr attr = unsafeAddPlaceHolders . run where run rel = do q <- liftQualify $ do sq <- untypeRelation (unUnique rel) qualifyQuery sq Projection.unsafeChangeContext <$> unsafeUniqueSubQuery attr q -- | Join unique sub-query with place-holder parameter 'p'. uniqueQuery' :: UniqueRelation p c r -> QueryUnique (PlaceHolders p, Projection c r) uniqueQuery' = uniqueQueryWithAttr Just' -- | Join unique sub-query with place-holder parameter 'p'. Query result is 'Maybe'. uniqueQueryMaybe' :: UniqueRelation p c r -> QueryUnique (PlaceHolders p, Projection c (Maybe r)) uniqueQueryMaybe' pr = do (ph, pj) <- uniqueQueryWithAttr Maybe pr return (ph, Projection.just pj) -- | Finalize 'QueryUnique' monad and generate 'UniqueRelation'. uniqueRelation' :: QueryUnique (PlaceHolders p, Projection c r) -> UniqueRelation p c r uniqueRelation' = unsafeUnique . unsafeTypeRelation . Unique.toSubQuery -- | Aggregated 'UniqueRelation'. aggregatedUnique :: Relation ph r -> Pi r a -> (Projection Flat a -> Projection Aggregated b) -> UniqueRelation ph Flat b aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do (ph, a) <- query' rel return (ph, ag $ Projection.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, Projection c (Maybe r)) queryScalar' ur = unsafeAddPlaceHolders . liftQualify $ Projection.unsafeFromScalarSubQuery <$> untypeRelation (unUnique ur) -- | Scalar sub-query. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> m (Projection c (Maybe r)) queryScalar = fmap snd . queryScalar' relational-query-0.9.5.1/src/Database/Relational/Query/Projectable.hs0000644000000000000000000005244213206454105023636 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Database.Relational.Query.Projectable -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines operators on various polymorphic projections. module Database.Relational.Query.Projectable ( -- * Projectable from SQL strings SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql', unsafeProjectSql, -- * Projections of values value, valueTrue, valueFalse, values, nothing, unsafeValueNull, -- * Placeholders PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders, pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH, -- * Projectable into SQL strings ProjectableShowSql (unsafeShowSql'), unsafeShowSql, -- * Operators (.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.), and', or', in', (.||.), (?||?), like, likeMaybe, like', likeMaybe', (.+.), (.-.), (.*.), (./.), (?+?), (?-?), (?*?), (?/?), isNothing, isJust, fromMaybe, not', exists, negate', fromIntegral', showNum, negateMaybe, fromIntegralMaybe, showNumMaybe, casesOrElse, casesOrElse', caseSearch, caseSearchMaybe, case', caseMaybe, SqlBinOp, unsafeBinOp, unsafeUniOp, -- * Terms for Window function types rank, denseRank, rowNumber, percentRank, cumeDist, -- * Zipping projections projectZip, (><), ProjectableIdZip (..), -- * 'Maybe' type projecitoins ProjectableMaybe (just, flattenMaybe), ) where import Prelude hiding (pi) import Data.String (IsString) 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.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) import qualified Database.Relational.Query.Internal.Sub as Internal import Database.Relational.Query.ProjectableClass (ProjectableFunctor (..), ProjectableApplicative (..), ) import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow) import Database.Relational.Query.TupleInstances () import Database.Relational.Query.ProjectableClass (ShowConstantTermsSQL, showConstantTermsSQL, ) import Database.Relational.Query.Projection (Projection, ListProjection) import qualified Database.Relational.Query.Projection as Projection -- | Interface to project SQL terms unsafely. class SqlProjectable p where -- | Unsafely project from SQL expression terms. unsafeProjectSqlTerms :: [StringSQL] -- ^ SQL expression strings -> p t -- ^ Result projection object -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection Flat) where unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection Aggregated) where unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms -- | Unsafely make 'Projection' from SQL terms. instance SqlProjectable (Projection OverWindow) where unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms class SqlProjectable p => OperatorProjectable p instance OperatorProjectable (Projection Flat) instance OperatorProjectable (Projection Aggregated) -- | Unsafely Project single SQL term. unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t unsafeProjectSql' = unsafeProjectSqlTerms . (:[]) -- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql''. unsafeProjectSql :: SqlProjectable p => String -> p t unsafeProjectSql = unsafeProjectSql' . stringSQL -- | Polymorphic projection of SQL null value. Semantics of comparing is unsafe. nothing :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), PersistableWidth a) => Projection c (Maybe a) nothing = proxyWidth persistableWidth where proxyWidth :: SqlProjectable (Projection c) => PersistableRecordWidth a -> Projection c (Maybe a) proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL {-# DEPRECATED unsafeValueNull "Use `nothing' instead of this." #-} -- | Deprecated. Polymorphic projection of SQL null value. unsafeValueNull :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), PersistableWidth a) => Projection c (Maybe a) unsafeValueNull = nothing -- | Generate polymorphic projection of SQL constant values from Haskell value. value :: (ShowConstantTermsSQL t, OperatorProjectable p) => t -> p t value = unsafeProjectSqlTerms . showConstantTermsSQL -- | Polymorphic proejction of SQL true value. valueTrue :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool) valueTrue = just $ value True -- | Polymorphic proejction of SQL false value. valueFalse :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool) valueFalse = just $ value False -- | Polymorphic proejction of SQL set value from Haskell list. values :: (ShowConstantTermsSQL t, OperatorProjectable p) => [t] -> ListProjection p t values = Projection.list . map value -- | Interface to get SQL term from projections. class ProjectableShowSql p where -- | Unsafely generate SQL expression term from projection object. unsafeShowSql' :: p a -- ^ Source projection object -> StringSQL -- ^ Result SQL expression string. -- | Unsafely generate SQL expression string from projection object. -- String interface of 'unsafeShowSql''. unsafeShowSql :: ProjectableShowSql p => p a -- ^ Source projection object -> String -- ^ Result SQL expression string. unsafeShowSql = showStringSQL . unsafeShowSql' -- | Unsafely get SQL term from 'Proejction'. instance ProjectableShowSql (Projection c) where unsafeShowSql' = Projection.unsafeStringSql -- | Binary operator type for SQL String. type SqlBinOp = Keyword -> Keyword -> Keyword -- | Unsafely make projection unary operator from SQL keyword. unsafeUniOp :: (ProjectableShowSql p0, SqlProjectable p1) => (Keyword -> Keyword) -> p0 a -> p1 b unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql' unsafeFlatUniOp :: (SqlProjectable p, ProjectableShowSql p) => Keyword -> p a -> p b unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw) -- | Unsafely make projection binary operator from string binary operator. unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p) => SqlBinOp -> p a -> p b -> p c unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $ op (unsafeShowSql' a) (unsafeShowSql' b) -- | Unsafely make compare projection binary operator from string binary operator. compareBinOp :: (SqlProjectable p, ProjectableShowSql p) => SqlBinOp -> p a -> p a -> p (Maybe Bool) compareBinOp = unsafeBinOp -- | Unsafely make numrical projection binary operator from string binary operator. monoBinOp :: (SqlProjectable p, ProjectableShowSql p) => SqlBinOp -> p a -> p a -> p a monoBinOp = unsafeBinOp -- | Compare operator corresponding SQL /=/ . (.=.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.=.) = compareBinOp (SQL..=.) -- | Compare operator corresponding SQL / p ft -> p ft -> p (Maybe Bool) (.<.) = compareBinOp (SQL..<.) -- | Compare operator corresponding SQL /<=/ . (.<=.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.<=.) = compareBinOp (SQL..<=.) -- | Compare operator corresponding SQL />/ . (.>.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.>.) = compareBinOp (SQL..>.) -- | Compare operator corresponding SQL />=/ . (.>=.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.>=.) = compareBinOp (SQL..>=.) -- | Compare operator corresponding SQL /<>/ . (.<>.) :: (OperatorProjectable p, ProjectableShowSql p) => p ft -> p ft -> p (Maybe Bool) (.<>.) = compareBinOp (SQL..<>.) -- | Logical operator corresponding SQL /AND/ . and' :: (OperatorProjectable p, ProjectableShowSql p) => p (Maybe Bool) -> p (Maybe Bool) -> p (Maybe Bool) and' = monoBinOp SQL.and -- | Logical operator corresponding SQL /OR/ . or' :: (OperatorProjectable p, ProjectableShowSql p) => p (Maybe Bool) -> p (Maybe Bool) -> p (Maybe Bool) or' = monoBinOp SQL.or -- | Logical operator corresponding SQL /NOT/ . not' :: (OperatorProjectable p, ProjectableShowSql p) => p (Maybe Bool) -> p (Maybe Bool) not' = unsafeFlatUniOp SQL.NOT -- | Logical operator corresponding SQL /EXISTS/ . exists :: (OperatorProjectable p, ProjectableShowSql p) => ListProjection (Projection Exists) r -> p (Maybe Bool) exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS . Projection.unsafeStringSqlList unsafeShowSql' -- | Concatinate operator corresponding SQL /||/ . (.||.) :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p a -> p a -> p a (.||.) = unsafeBinOp (SQL..||.) -- | Concatinate operator corresponding SQL /||/ . Maybe type version. (?||?) :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?||?) = unsafeBinOp (SQL..||.) unsafeLike :: (OperatorProjectable p, ProjectableShowSql p) => p a -> p b -> p (Maybe Bool) unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE) -- | String-compare operator corresponding SQL /LIKE/ . like' :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p a -> p a -> p (Maybe Bool) x `like'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . likeMaybe' :: (OperatorProjectable p, ProjectableShowSql p, IsString a) => p (Maybe a) -> p (Maybe a) -> p (Maybe Bool) x `likeMaybe'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . like :: (OperatorProjectable p, ProjectableShowSql p, IsString a, ShowConstantTermsSQL a) => p a -> a -> p (Maybe Bool) x `like` a = x `like'` value a -- | String-compare operator corresponding SQL /LIKE/ . Maybe type version. likeMaybe :: (OperatorProjectable p, ProjectableShowSql p, IsString a, ShowConstantTermsSQL a) => p (Maybe a) -> a -> p (Maybe Bool) x `likeMaybe` a = x `unsafeLike` value a -- | Unsafely make number projection binary operator from SQL operator string. monoBinOp' :: (SqlProjectable p, ProjectableShowSql p) => Keyword -> p a -> p a -> p a monoBinOp' = monoBinOp . SQL.defineBinOp -- | Number operator corresponding SQL /+/ . (.+.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (.+.) = monoBinOp' "+" -- | Number operator corresponding SQL /-/ . (.-.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (.-.) = monoBinOp' "-" -- | Number operator corresponding SQL /// . (./.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (./.) = monoBinOp' "/" -- | Number operator corresponding SQL /*/ . (.*.) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a -> p a (.*.) = monoBinOp' "*" -- | Number negate uni-operator corresponding SQL /-/. negate' :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p a -> p a negate' = unsafeFlatUniOp $ SQL.word "-" unsafeCastProjectable :: (SqlProjectable p, ProjectableShowSql p) => p a -> p b unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql' -- | Number fromIntegral uni-operator. fromIntegral' :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b) => p a -> p b fromIntegral' = unsafeCastProjectable -- | Unsafely show number into string-like type in projections. showNum :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b) => p a -> p b showNum = unsafeCastProjectable -- | Number operator corresponding SQL /+/ . (?+?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?+?) = monoBinOp' "+" -- | Number operator corresponding SQL /-/ . (?-?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?-?) = monoBinOp' "-" -- | Number operator corresponding SQL /// . (?/?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?/?) = monoBinOp' "/" -- | Number operator corresponding SQL /*/ . (?*?) :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) -> p (Maybe a) (?*?) = monoBinOp' "*" -- | Number negate uni-operator corresponding SQL /-/. negateMaybe :: (OperatorProjectable p, ProjectableShowSql p, Num a) => p (Maybe a) -> p (Maybe a) negateMaybe = unsafeFlatUniOp $ SQL.word "-" -- | Number fromIntegral uni-operator. fromIntegralMaybe :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b) => p (Maybe a) -> p (Maybe b) fromIntegralMaybe = unsafeCastProjectable -- | Unsafely show number into string-like type in projections. showNumMaybe :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b) => p (Maybe a) -> p (Maybe b) showNumMaybe = unsafeCastProjectable -- | Search case operator correnponding SQL search /CASE/. -- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ caseSearch :: OperatorProjectable (Projection c) => [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses -> Projection c a -- ^ Else result projection -> Projection c a -- ^ Result projection caseSearch = Internal.caseSearch -- | Same as 'caseSearch', but you can write like `casesOrElse` . casesOrElse :: OperatorProjectable (Projection c) => [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses -> Projection c a -- ^ Else result projection -> Projection c a -- ^ Result projection casesOrElse = caseSearch -- | Null default version of 'caseSearch'. caseSearchMaybe :: (OperatorProjectable (Projection c) {- (Projection c) is always ProjectableMaybe -}, PersistableWidth a) => [(Projection c (Maybe Bool), Projection c (Maybe a))] -- ^ Each when clauses -> Projection c (Maybe a) -- ^ Result projection caseSearchMaybe cs = caseSearch cs unsafeValueNull -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ case' :: OperatorProjectable (Projection c) => Projection c a -- ^ Projection value to match -> [(Projection c a, Projection c b)] -- ^ Each when clauses -> Projection c b -- ^ Else result projection -> Projection c b -- ^ Result projection case' = Internal.case' -- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` . casesOrElse' :: OperatorProjectable (Projection c) => (Projection c a, [(Projection c a, Projection c b)]) -- ^ Projection value to match and each when clauses list -> Projection c b -- ^ Else result projection -> Projection c b -- ^ Result projection casesOrElse' = uncurry case' -- | Null default version of 'case''. caseMaybe :: (OperatorProjectable (Projection c) {- (Projection c) is always ProjectableMaybe -}, PersistableWidth b) => Projection c a -- ^ Projection value to match -> [(Projection c a, Projection c (Maybe b))] -- ^ Each when clauses -> Projection c (Maybe b) -- ^ Result projection caseMaybe v cs = case' v cs unsafeValueNull -- | Binary operator corresponding SQL /IN/ . in' :: (OperatorProjectable p, ProjectableShowSql p) => p t -> ListProjection p t -> p (Maybe Bool) in' a lp = unsafeProjectSql' . SQL.paren $ SQL.in' (unsafeShowSql' a) (Projection.unsafeStringSqlList unsafeShowSql' lp) -- | Operator corresponding SQL /IS NULL/ , and extended against record types. isNothing :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) => Projection c (Maybe r) -> Projection c (Maybe Bool) isNothing mr = unsafeProjectSql' $ SQL.paren $ (SQL.defineBinOp SQL.IS) (Projection.unsafeStringSqlNotNullMaybe mr) SQL.NULL -- | Operator corresponding SQL /NOT (... IS NULL)/ , and extended against record type. isJust :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) => Projection c (Maybe r) -> Projection c (Maybe Bool) isJust = not' . isNothing -- | Operator from maybe type using record extended 'isNull'. fromMaybe :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r) => Projection c r -> Projection c (Maybe r) -> Projection c r fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p unsafeUniTermFunction :: SqlProjectable p => Keyword -> p t unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()") -- | /RANK()/ term. rank :: Integral a => Projection OverWindow a rank = unsafeUniTermFunction SQL.RANK -- | /DENSE_RANK()/ term. denseRank :: Integral a => Projection OverWindow a denseRank = unsafeUniTermFunction SQL.DENSE_RANK -- | /ROW_NUMBER()/ term. rowNumber :: Integral a => Projection OverWindow a rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER -- | /PERCENT_RANK()/ term. percentRank :: Projection OverWindow Double percentRank = unsafeUniTermFunction SQL.PERCENT_RANK -- | /CUME_DIST()/ term. cumeDist :: Projection OverWindow Double cumeDist = unsafeUniTermFunction SQL.CUME_DIST -- | Placeholder parameter type which has real parameter type arguemnt 'p'. data PlaceHolders p = PlaceHolders -- | Unsafely add placeholder parameter to queries. unsafeAddPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a) unsafeAddPlaceHolders = fmap ((,) PlaceHolders) -- | Unsafely get placeholder parameter unsafePlaceHolders :: PlaceHolders p unsafePlaceHolders = PlaceHolders -- | No placeholder semantics unitPlaceHolder :: PlaceHolders () unitPlaceHolder = unsafePlaceHolders -- | No placeholder semantics. Same as `unitPlaceHolder` unitPH :: PlaceHolders () unitPH = unitPlaceHolder -- | Unsafely cast placeholder parameter type. unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b unsafeCastPlaceHolders PlaceHolders = PlaceHolders -- | Provide scoped placeholder from width and return its parameter object. pwPlaceholder :: SqlProjectable p => PersistableRecordWidth a -> (p a -> b) -> (PlaceHolders a, b) pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw) where projectPlaceHolder :: SqlProjectable p => PersistableRecordWidth a -> p a projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth -- | Provide scoped placeholder and return its parameter object. placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) -> (PlaceHolders t, a) placeholder' = pwPlaceholder persistableWidth -- | Provide scoped placeholder and return its parameter object. Monadic version. placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a) placeholder f = do let (ph, ma) = placeholder' f a <- ma return (ph, a) -- | Zipping projections. projectZip :: ProjectableApplicative p => p a -> p b -> p (a, b) projectZip pa pb = (,) |$| pa |*| pb -- | Binary operator the same as 'projectZip'. (><) :: ProjectableApplicative p => p a -> p b -> p (a, b) (><) = projectZip -- | Interface to control 'Maybe' of phantom type in projections. class ProjectableMaybe p where -- | Cast projection phantom type into 'Maybe'. just :: p a -> p (Maybe a) -- | Compose nested 'Maybe' phantom type on projection. flattenMaybe :: p (Maybe (Maybe a)) -> p (Maybe a) -- | Control phantom 'Maybe' type in placeholder parameters. instance ProjectableMaybe PlaceHolders where just = unsafeCastPlaceHolders flattenMaybe = unsafeCastPlaceHolders -- | Control phantom 'Maybe' type in projection type 'Projection'. instance ProjectableMaybe (Projection c) where just = Projection.just flattenMaybe = Projection.flattenMaybe -- | Zipping except for identity element laws. class ProjectableApplicative p => ProjectableIdZip p where leftId :: p ((), a) -> p a rightId :: p (a, ()) -> p a -- | Zipping except for identity element laws against placeholder parameter type. instance ProjectableIdZip PlaceHolders where leftId = unsafeCastPlaceHolders rightId = unsafeCastPlaceHolders -- | Compose seed of record type 'PlaceHolders'. instance ProjectableFunctor PlaceHolders where _ |$| PlaceHolders = PlaceHolders -- | Compose record type 'PlaceHolders' using applicative style. instance ProjectableApplicative PlaceHolders where pf |*| pa = unsafeCastPlaceHolders (pf >< pa) infixl 7 .*., ./., ?*?, ?/? infixl 6 .+., .-., ?+?, ?-? infixl 5 .||., ?||? infix 4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'` infixr 3 `and'` infixr 2 `or'` infixl 1 >< relational-query-0.9.5.1/src/Database/Relational/Query/Arrow.hs0000644000000000000000000004300213206454105022466 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.Arrow -- Copyright : 2015-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines arrow version combinators which -- improves type-safty on building queries. -- Referencing the local projections may cause to break -- the result query. -- It is possible to controls injection of previous local projections -- by restricting domain type of arrow. This idea is imported from Opaleye: -- -- * -- * -- -- Importing this module instead of "Database.Relational.Query" enables -- to build query using arrow combinators. module Database.Relational.Query.Arrow ( module Database.Relational.Query, all', distinct, query, queryMaybe, query', queryMaybe', queryList, queryList', queryExists, queryExists', queryListU, queryListU', queryScalar, queryScalar', queryScalarU, queryScalarU', uniqueQuery', uniqueQueryMaybe', on, wheres, having, groupBy, placeholder, relation, relation', aggregateRelation, aggregateRelation', uniqueRelation', groupBy', key, key', set, bkey, rollup, cube, groupingSets, orderBy', orderBy, asc, desc, partitionBy, over, assign, derivedUpdate', derivedUpdate, derivedInsertValue', derivedInsertValue, derivedDelete', derivedDelete, QueryA, QuerySimple, QueryAggregate, QueryUnique, AggregatingSet, AggregatingSetList, AggregatingPowerSet, Orderings, Window, Assignings, AssignStatement, Register, RestrictedStatement, ) where import Control.Category (Category) import Control.Arrow (Arrow, Kleisli (..)) import Database.Record import Database.Relational.Query hiding (all', distinct, query, queryMaybe, query', queryMaybe', queryList, queryList', queryScalar, queryScalar', uniqueQuery', uniqueQueryMaybe', on, wheres, having, groupBy, placeholder, relation, relation', aggregateRelation, aggregateRelation', uniqueRelation', groupBy', key, key', set, bkey, rollup, cube, groupingSets, orderBy', orderBy, asc, desc, partitionBy, over, derivedUpdate', derivedUpdate, derivedInsertValue', derivedInsertValue, derivedDelete', derivedDelete, QuerySimple, QueryAggregate, QueryUnique, Window, Register) import qualified Database.Relational.Query as Monadic import Database.Relational.Query.Projection (ListProjection) import qualified Database.Relational.Query.Monad.Trans.Aggregating as Monadic import qualified Database.Relational.Query.Monad.Trans.Ordering as Monadic import qualified Database.Relational.Query.Monad.Trans.Assigning as Monadic -- | Arrow to build queries. newtype QueryA m a b = QueryA (Kleisli m a b) deriving (Category, Arrow) queryA :: (a -> m b) -> QueryA m a b queryA = QueryA . Kleisli runQueryA :: QueryA m a b -> a -> m b runQueryA (QueryA k) = runKleisli k runAofM :: (m b -> c) -> QueryA m () b -> c runAofM = (. (`runQueryA` ())) -- | Arrow type corresponding to 'Monadic.QuerySimple' type QuerySimple = QueryA Monadic.QuerySimple -- | Arrow type corresponding to 'Monadic.QueryAggregate' type QueryAggregate = QueryA Monadic.QueryAggregate -- | Arrow type corresponding to 'Monadic.QueryUnique' type QueryUnique = QueryA Monadic.QueryUnique -- | Arrow type corresponding to 'Monadic.AggregatingSet' type AggregatingSet = QueryA Monadic.AggregatingSet -- | Arrow type corresponding to 'Monadic.AggregatingSetList' type AggregatingSetList = QueryA Monadic.AggregatingSetList -- | Arrow type corresponding to 'Monadic.AggregatingPowerSet' type AggregatingPowerSet = QueryA Monadic.AggregatingPowerSet -- | Arrow type corresponding to 'Monadic.Orderings' type Orderings c m = QueryA (Monadic.Orderings c m) -- | Arrow type corresponding to 'Monadic.Window' type Window c = QueryA (Monadic.Window c) -- | Arrow type corresponding to 'Monadic.Assignings' type Assignings r m = QueryA (Monadic.Assignings r m) -- | Arrow type corresponding to 'Monadic.AssignStatement' type AssignStatement r a = Assignings r Restrict (Projection Flat r) a -- | Arrow type corresponding to 'Monadic.Register' type Register r a = QueryA (Monadic.Register r) () a -- | Arrow type corresponding to 'Monadic.RestrictedStatement' type RestrictedStatement r a = QueryA Monadic.Restrict (Projection Flat r) a -- | Same as 'Monadic.all''. Arrow version. all' :: MonadQuery m => QueryA m () () all' = queryA $ \() -> Monadic.all' -- | Same as 'Monadic.distinct'. Arrow version. distinct :: MonadQuery m => QueryA m () () distinct = queryA $ \() -> Monadic.distinct -- | Same as 'Monadic.query'. Arrow version. -- The result arrow is not injected by local projections. query :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> QueryA m () (Projection Flat r) query r = queryA $ \() -> Monadic.query r -- | Same as 'Monadic.queryMaybe'. Arrow version. -- The result arrow is not injected by any local projections. queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> QueryA m () (Projection Flat (Maybe r)) queryMaybe r = queryA $ \() -> Monadic.queryMaybe r -- | Same as 'Monadic.query''. Arrow version. -- The result arrow is not injected by any local projections. query' :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation p r -> QueryA m () (PlaceHolders p, Projection Flat r) query' r = queryA $ \() -> Monadic.query' r -- | Same as 'Monadic.queryMaybe''. Arrow version. -- The result arrow is not injected by any local projections. queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation p r -> QueryA m () (PlaceHolders p, Projection Flat (Maybe r)) queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r unsafeQueryList :: MonadQualify ConfigureQuery m => (a -> Relation () r) -> QueryA m a (ListProjection (Projection c) r) unsafeQueryList rf = queryA $ Monadic.queryList . rf unsafeQueryList' :: MonadQualify ConfigureQuery m => (a -> Relation p r) -> QueryA m a (PlaceHolders p, ListProjection (Projection c) r) unsafeQueryList' rf = queryA $ Monadic.queryList' . rf -- | Same as 'Monadic.queryList'. Arrow version. -- The result arrow is designed to be injected by local projections. queryList :: MonadQualify ConfigureQuery m => (Projection c a -> Relation () r) -> QueryA m (Projection c a) (ListProjection (Projection c) r) queryList = unsafeQueryList -- | Same as 'Monadic.queryList''. Arrow version. -- The result arrow is designed to be injected by local projections. queryList' :: MonadQualify ConfigureQuery m => (Projection c a -> Relation p r) -> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection c) r) queryList' = unsafeQueryList' -- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version. -- The result arrow is designed to be injected by local projections. queryExists :: MonadQualify ConfigureQuery m => (Projection c a -> Relation () r) -> QueryA m (Projection c a) (ListProjection (Projection Exists) r) queryExists = unsafeQueryList -- | Same as 'Monadic.queryList'' to pass this result to 'exists' operator. Arrow version. -- The result arrow is designed to be injected by local projections. queryExists' :: MonadQualify ConfigureQuery m => (Projection c a -> Relation p r) -> QueryA m (Projection c a) (PlaceHolders p, ListProjection (Projection Exists) r) queryExists' = unsafeQueryList' -- | Same as 'Monadic.queryList'. Arrow version. -- Useful for no reference cases to local projections. queryListU :: MonadQualify ConfigureQuery m => Relation () r -> QueryA m () (ListProjection (Projection c) r) queryListU r = unsafeQueryList $ \() -> r -- | Same as 'Monadic.queryList''. Arrow version. -- Useful for no reference cases to local projections. queryListU' :: MonadQualify ConfigureQuery m => Relation p r -> QueryA m () (PlaceHolders p, ListProjection (Projection c) r) queryListU' r = unsafeQueryList' $ \() -> r unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (a -> UniqueRelation () c r) -> QueryA m a (Projection c (Maybe r)) unsafeQueryScalar rf = queryA $ Monadic.queryScalar . rf unsafeQueryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (a -> UniqueRelation p c r) -> QueryA m a (PlaceHolders p, Projection c (Maybe r)) unsafeQueryScalar' rf = queryA $ Monadic.queryScalar' . rf -- | Same as 'Monadic.queryScalar'. Arrow version. -- The result arrow is designed to be injected by any local projection. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (Projection c a -> UniqueRelation () c r) -> QueryA m (Projection c a) (Projection c (Maybe r)) queryScalar = unsafeQueryScalar -- | Same as 'Monadic.queryScalar''. Arrow version. -- The result arrow is designed to be injected by any local projection. queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (Projection c a -> UniqueRelation p c r) -> QueryA m (Projection c a) (PlaceHolders p, Projection c (Maybe r)) queryScalar' = unsafeQueryScalar' -- | Same as 'Monadic.queryScalar'. Arrow version. -- Useful for no reference cases to local projections. queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> QueryA m () (Projection c (Maybe r)) queryScalarU r = unsafeQueryScalar $ \() -> r -- | Same as 'Monadic.queryScalar''. Arrow version. -- Useful for no reference cases to local projections. queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation p c r -> QueryA m () (PlaceHolders p, Projection c (Maybe r)) queryScalarU' r = unsafeQueryScalar' $ \() -> r -- | Same as 'Monadic.uniqueQuery''. Arrow version. -- The result arrow is not injected by local projections. uniqueQuery' :: UniqueRelation p c r -> QueryA Monadic.QueryUnique () (PlaceHolders p, Projection c r) uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r -- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version. -- The result arrow is not injected by local projections. uniqueQueryMaybe' :: UniqueRelation p c r -> QueryA Monadic.QueryUnique () (PlaceHolders p, Projection c (Maybe r)) uniqueQueryMaybe' r = queryA $ \() -> Monadic.uniqueQueryMaybe' r -- | Same as 'Monadic.on'. Arrow version. -- The result arrow is designed to be injected by local conditional flat-projections. on :: MonadQuery m => QueryA m (Projection Flat (Maybe Bool)) () on = queryA Monadic.on -- | Same as 'Monadic.wheres'. Arrow version. -- The result arrow is designed to be injected by local conditional flat-projections. wheres :: MonadRestrict Flat m => QueryA m (Projection Flat (Maybe Bool)) () wheres = queryA Monadic.wheres -- | Same as 'Monadic.having'. Arrow version. -- The result arrow is designed to be injected by local conditional aggregated-projections. having :: MonadRestrict Aggregated m => QueryA m (Projection Aggregated (Maybe Bool)) () having = queryA Monadic.having -- | Same as 'Monadic.groupBy'. Arrow version. -- The result arrow is designed to be injected by local flat-projections. groupBy :: MonadAggregate m => QueryA m (Projection Flat r) (Projection Aggregated r) groupBy = queryA Monadic.groupBy -- | Same as 'Monadic.placeholder'. Arrow version. -- The result arrow is designed to be injected by locally built arrow using placeholders. placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => QueryA m (QueryA m (p t) a) (PlaceHolders t, a) placeholder = queryA $ Monadic.placeholder . runQueryA -- | Same as 'Monadic.relation'. -- Finalize query-building arrow instead of query-building monad. relation :: QuerySimple () (Projection Flat r) -> Relation () r relation = runAofM Monadic.relation -- | Same as 'Monadic.relation''. -- Finalize query-building arrow instead of query-building monad. relation' :: QuerySimple () (PlaceHolders p, Projection Flat r) -> Relation p r relation' = runAofM Monadic.relation' -- | Same as 'Monadic.aggregateRelation'. -- Finalize query-building arrow instead of query-building monad. aggregateRelation :: QueryAggregate () (Projection Aggregated r) -> Relation () r aggregateRelation = runAofM Monadic.aggregateRelation -- | Same as 'Monadic.aggregateRelation''. -- Finalize query-building arrow instead of query-building monad. aggregateRelation' :: QueryAggregate () (PlaceHolders p, Projection Aggregated r) -> Relation p r aggregateRelation' = runAofM Monadic.aggregateRelation' -- | Same as 'Monadic.uniqueRelation''. -- Finalize query-building arrow instead of query-building monad. uniqueRelation' :: QueryUnique () (PlaceHolders p, Projection c r) -> UniqueRelation p c r uniqueRelation' = runAofM Monadic.uniqueRelation' -- | Same as 'Monadic.groupBy''. -- This arrow is designed to be injected by local 'AggregateKey'. groupBy' :: MonadAggregate m => QueryA m (AggregateKey (Projection Aggregated r)) (Projection Aggregated r) groupBy' = queryA Monadic.groupBy' -- | Same as 'Monadic.key'. -- This arrow is designed to be injected by local flat-projections. key :: AggregatingSet (Projection Flat r) (Projection Aggregated (Maybe r)) key = queryA Monadic.key -- | Same as 'Monadic.key''. -- This arrow is designed to be injected by local 'AggregteKey'. key' :: AggregatingSet (AggregateKey a) a key' = queryA Monadic.key' -- | Same as 'Monadic.set'. -- This arrow is designed to be injected by locally built 'AggregtingSet' arrow. set :: AggregatingSetList (AggregatingSet () a) a set = queryA $ runAofM Monadic.set -- | Same as 'Monadic.bkey'. -- This arrow is designed to be injected by local flat-projections. bkey :: AggregatingPowerSet (Projection Flat r) (Projection Aggregated (Maybe r)) bkey = queryA Monadic.bkey -- | Same as 'Monadic.rollup'. -- Finalize locally built 'AggregatingPowerSet'. rollup :: AggregatingPowerSet () a -> AggregateKey a rollup = runAofM Monadic.rollup -- | Same as 'Monadic.cube'. -- Finalize locally built 'AggregatingPowerSet'. cube :: AggregatingPowerSet () a -> AggregateKey a cube = runAofM Monadic.cube -- | Same as 'Monadic.groupingSets'. -- Finalize locally built 'AggregatingSetList'. groupingSets :: AggregatingSetList () a -> AggregateKey a groupingSets = runAofM Monadic.groupingSets -- | Same as 'Monadic.orderBy''. -- The result arrow is designed to be injected by local projections. orderBy' :: Monad m => Order -> Nulls -> Orderings c m (Projection 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 projections. orderBy :: Monad m => Order -> Orderings c m (Projection c t) () orderBy o = queryA (`Monadic.orderBy` o) -- | Same as 'Monadic.asc'. -- The result arrow is designed to be injected by local projections. asc :: Monad m => Orderings c m (Projection c t) () asc = queryA Monadic.asc -- | Same as 'Monadic.desc'. -- The result arrow is designed to be injected by local projections. desc :: Monad m => Orderings c m (Projection c t) () desc = queryA Monadic.desc -- | Same as 'Monadic.partitionBy'. -- The result arrow is designed to be injected by local projections. partitionBy :: Window c (Projection c r) () partitionBy = queryA Monadic.partitionBy -- | Same as 'Monadic.over'. -- Make window function result projection using built 'Window' arrow. over :: SqlProjectable (Projection c) => Projection OverWindow a -> Window c () () -> Projection c a over po = runAofM $ Monadic.over po infix 8 `over` -- | Make 'Monadic.AssignTarget' into arrow which is designed to be -- injected by local projection assignees. assign :: Monad m => Monadic.AssignTarget r v -> Assignings r m (Projection Flat v) () assign t = queryA (`Monadic.assignTo` t) -- | Same as 'Monadic.derivedUpdate''. -- Make 'Update' from assigning statement arrow using configuration. derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p derivedUpdate' config = Monadic.derivedUpdate' config . runQueryA -- | Same as 'Monadic.derivedUpdate'. -- Make 'Update' from assigning statement arrow. derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p derivedUpdate = Monadic.derivedUpdate . runQueryA -- | Same as 'Monadic.derivedInsertValue''. -- Make 'Insert' from register arrow using configuration. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p derivedInsertValue' config = Monadic.derivedInsertValue' config . ($ ()) . runQueryA -- | Same as 'Monadic.derivedInsertValue'. -- Make 'Insert' from register arrow. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p derivedInsertValue = Monadic.derivedInsertValue . ($ ()) . runQueryA -- | Same as 'Monadic.derivedDelete''. -- Make 'Update' from restrict statement arrow using configuration. derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete' config = Monadic.derivedDelete' config . runQueryA -- | Same as 'Monadic.derivedDelete'. -- Make 'Update' from restrict statement arrow. derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p derivedDelete = Monadic.derivedDelete . runQueryA relational-query-0.9.5.1/src/Database/Relational/Query/ProjectableClass.hs0000644000000000000000000000636513206454105024627 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Relational.Query.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.Query.ProjectableClass ( -- * Interface to specify record constructors. ProductConstructor (..), -- * ProjectableFunctor and ProjectableApplicative ProjectableFunctor (..), ProjectableApplicative (..), ipfmap, -- * Literal SQL terms ShowConstantTermsSQL (..), showConstantTermsSQL, StringSQL, ) where import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from) import Data.Monoid (mempty, (<>)) import Data.DList (DList, toList) import Database.Relational.Query.Internal.SQL (StringSQL) -- | Specify tuple like record constructors which are allowed to define 'ProjectableFunctor'. class ProductConstructor r where -- | The constructor which has type 'r'. productConstructor :: r -- | Weaken functor on projections. class ProjectableFunctor p where -- | Method like 'fmap'. (|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b -- | Same as '|$|' other than using inferred record constructor. ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b)) => p a -> p b ipfmap = (|$|) productConstructor -- | Weaken applicative functor on projections. class ProjectableFunctor p => ProjectableApplicative p where -- | Method like '<*>'. (|*|) :: p (a -> b) -> p a -> p b infixl 4 |$|, |*| -- | Convert from haskell record to SQL terms list. showConstantTermsSQL :: ShowConstantTermsSQL a => a -> [StringSQL] showConstantTermsSQL = toList . showConstantTermsSQL' {- | 'ShowConstantTermsSQL' 'a' is implicit rule to derive function to convert from haskell record type 'a' into constant SQL terms. Generic programming () with default signature is available for 'ShowConstantTermsSQL' class, so you can make instance like below: @ \{\-\# LANGUAGE DeriveGeneric \#\-\} import GHC.Generics (Generic) -- data Foo = Foo { ... } deriving Generic instance ShowConstantTermsSQL Foo @ -} class ShowConstantTermsSQL a where showConstantTermsSQL' :: a -> DList StringSQL default showConstantTermsSQL' :: (Generic a, GShowConstantTermsSQL (Rep a)) => a -> DList StringSQL showConstantTermsSQL' = gShowConstantTermsSQL . from class GShowConstantTermsSQL f where gShowConstantTermsSQL :: f a -> DList StringSQL instance GShowConstantTermsSQL U1 where gShowConstantTermsSQL U1 = mempty instance (GShowConstantTermsSQL a, GShowConstantTermsSQL b) => GShowConstantTermsSQL (a :*: b) where gShowConstantTermsSQL (a :*: b) = gShowConstantTermsSQL a <> gShowConstantTermsSQL b instance GShowConstantTermsSQL a => GShowConstantTermsSQL (M1 i c a) where gShowConstantTermsSQL (M1 a) = gShowConstantTermsSQL a instance ShowConstantTermsSQL a => GShowConstantTermsSQL (K1 i a) where gShowConstantTermsSQL (K1 a) = showConstantTermsSQL' a relational-query-0.9.5.1/src/Database/Relational/Query/BaseTH.hs0000644000000000000000000000561513206454105022512 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} -- | -- Module : Database.Relational.Query.BaseTH -- 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.Query.BaseTH ( defineProductConstructorInstance, defineTupleProductConstructor, defineTupleShowConstantInstance, defineTuplePi, ) where import Control.Applicative ((<$>)) import Data.List (foldl') import Language.Haskell.TH (Q, Name, mkName, tupleDataName, normalB, classP, varP, TypeQ, forallT, arrowT, varT, tupleT, appT, Dec, sigD, valD, instanceD, ExpQ, conE, TyVarBndr (PlainTV), ) import Database.Record.Persistable (PersistableWidth, persistableWidth, PersistableRecordWidth, runPersistableRecordWidth) import Database.Relational.Query.ProjectableClass (ProductConstructor (..), ShowConstantTermsSQL (..), ) import Database.Relational.Query.Pi.Unsafe (Pi, definePi) -- | Make template for 'ProductConstructor' instance. defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec] defineProductConstructorInstance recTypeQ recData colTypes = [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where productConstructor = $(recData) |] 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 ProductConstructor instance of tuple type. defineTupleProductConstructor :: Int -> Q [Dec] defineTupleProductConstructor n = do let ((_, vs), tty) = tupleN n defineProductConstructorInstance tty (conE $ tupleDataName n) vs -- | Make template of 'ShowConstantTermsSQL' instance of tuple type. defineTupleShowConstantInstance :: Int -> Q [Dec] defineTupleShowConstantInstance n = do let ((_, vs), tty) = tupleN n (:[]) <$> instanceD -- in template-haskell 2.8 or older, Pred is not Type (mapM (classP ''ShowConstantTermsSQL . (:[])) vs) [t| ShowConstantTermsSQL $tty |] [] tuplePi :: Int -> Int -> Q [Dec] tuplePi n i = do let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'" ((ns, vs), tty) = tupleN n sig <- sigD selN $ forallT (map PlainTV ns) (mapM (classP ''PersistableWidth . (:[])) vs) [t| Pi $tty $(vs !! i) |] val <- valD (varP selN) (normalB [| definePi $(foldl' (\e t -> [| $e + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]) [| 0 :: Int |] $ take i vs) |]) [] return [sig, val] -- | Make templates of projection paths for tuple types. defineTuplePi :: Int -> Q [Dec] defineTuplePi n = concat <$> mapM (tuplePi n) [0 .. n - 1] relational-query-0.9.5.1/src/Database/Relational/Query/Effect.hs0000644000000000000000000001736313206454105022603 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Effect -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines effect statements -- like update and delete. module Database.Relational.Query.Effect ( -- * Object to express simple restriction. Restriction, restriction, restriction', -- * Object to express update target columns and restriction. UpdateTarget, updateTarget, updateTarget', liftTargetAllColumn, liftTargetAllColumn', updateTargetAllColumn, updateTargetAllColumn', -- * Object to express insert terget. InsertTarget, insertTarget, insertTarget', piRegister, -- * Generate SQL from restriction. sqlWhereFromRestriction, sqlFromUpdateTarget, sqlChunkFromInsertTarget, sqlFromInsertTarget, ) where import Data.Monoid ((<>)) import Language.SQL.Keyword (Keyword(..)) import Database.Record.Persistable (PersistableWidth) import Database.Relational.Query.Internal.Config (Config (chunksInsertSize), defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL) import Database.Relational.Query.Internal.BaseSQL (composeSets, composeChunkValuesWithColumns) import Database.Relational.Query.Pi (Pi, id') import qualified Database.Relational.Query.Pi.Unsafe as Pi import Database.Relational.Query.Table (Table, TableDerivable, derivedTable) import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Sub (composeWhere) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, pwPlaceholder, placeholder, (><), rightId) import Database.Relational.Query.Monad.Trans.Assigning (assignings, (<-#)) import Database.Relational.Query.Monad.Restrict (RestrictedStatement) import qualified Database.Relational.Query.Monad.Restrict as Restrict import Database.Relational.Query.Monad.Assign (AssignStatement) import qualified Database.Relational.Query.Monad.Assign as Assign import Database.Relational.Query.Monad.Register (Register) import qualified Database.Relational.Query.Monad.Register as Register -- | Restriction type with place-holder parameter 'p' and projection record type 'r'. newtype Restriction p r = Restriction (RestrictedStatement r (PlaceHolders p)) -- | Finalize 'Restrict' monad and generate 'Restriction'. restriction :: RestrictedStatement r () -> Restriction () r restriction = Restriction . ((>> return unitPlaceHolder) .) -- | Finalize 'Restrict' monad and generate 'Restriction' with place-holder parameter 'p' restriction' :: RestrictedStatement r (PlaceHolders p) -> Restriction p r restriction' = Restriction runRestriction :: Restriction p r -> RestrictedStatement r (PlaceHolders p) runRestriction (Restriction qf) = fmap fst . unsafeAddPlaceHolders . qf -- | SQL WHERE clause 'StringSQL' string from 'Restriction'. sqlWhereFromRestriction :: Config -> Table r -> Restriction p r -> StringSQL sqlWhereFromRestriction config tbl (Restriction q) = composeWhere rs where (_ph, rs) = Restrict.extract (q $ Projection.unsafeFromTable tbl) config -- | Show where clause. instance TableDerivable r => Show (Restriction p r) where show = showStringSQL . sqlWhereFromRestriction defaultConfig derivedTable -- | UpdateTarget type with place-holder parameter 'p' and projection record type 'r'. newtype UpdateTarget p r = UpdateTarget (AssignStatement r (PlaceHolders p)) -- | Finalize 'Target' monad and generate 'UpdateTarget'. updateTarget :: AssignStatement r () -> UpdateTarget () r updateTarget = UpdateTarget . ((>> return unitPlaceHolder) .) -- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'. updateTarget' :: AssignStatement r (PlaceHolders p) -> UpdateTarget p r updateTarget' = UpdateTarget _runUpdateTarget :: UpdateTarget p r -> AssignStatement r (PlaceHolders p) _runUpdateTarget (UpdateTarget qf) = fmap fst . unsafeAddPlaceHolders . qf updateAllColumn :: PersistableWidth r => Restriction p r -> AssignStatement r (PlaceHolders (r, p)) updateAllColumn rs proj = do (ph0, ()) <- placeholder (\ph -> id' <-# ph) ph1 <- assignings $ runRestriction rs proj return $ ph0 >< ph1 -- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. liftTargetAllColumn :: PersistableWidth r => Restriction () r -> UpdateTarget r r liftTargetAllColumn rs = updateTarget' $ \proj -> fmap rightId $ updateAllColumn rs proj -- | Lift 'Restriction' to 'UpdateTarget'. Update target columns are all. With placefolder type 'p'. liftTargetAllColumn' :: PersistableWidth r => Restriction p r -> UpdateTarget (r, p) r liftTargetAllColumn' rs = updateTarget' $ updateAllColumn rs -- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. updateTargetAllColumn :: PersistableWidth r => RestrictedStatement r () -> UpdateTarget r r updateTargetAllColumn = liftTargetAllColumn . restriction -- | Finalize 'Restrict' monad and generate 'UpdateTarget'. Update target columns are all. With placefolder type 'p'. updateTargetAllColumn' :: PersistableWidth r => RestrictedStatement r (PlaceHolders p) -> UpdateTarget (r, p) r updateTargetAllColumn' = liftTargetAllColumn' . restriction' -- | SQL SET clause and WHERE clause 'StringSQL' string from 'UpdateTarget' sqlFromUpdateTarget :: Config -> Table r -> UpdateTarget p r -> StringSQL sqlFromUpdateTarget config tbl (UpdateTarget q) = composeSets (asR tbl) <> composeWhere rs where ((_ph, asR), rs) = Assign.extract (q (Projection.unsafeFromTable tbl)) config instance TableDerivable r => Show (UpdateTarget p r) where show = showStringSQL . sqlFromUpdateTarget defaultConfig derivedTable -- | InsertTarget type with place-holder parameter 'p' and projection record type 'r'. newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p)) -- | Finalize 'Register' monad and generate 'InsertTarget'. insertTarget :: Register r () -> InsertTarget () r insertTarget = InsertTarget . (>> return unitPlaceHolder) -- | Finalize 'Target' monad and generate 'UpdateTarget' with place-holder parameter 'p'. insertTarget' :: Register r (PlaceHolders p) -> InsertTarget p r insertTarget' = InsertTarget -- | 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 -- | 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 th = chunksInsertSize config n = (th + w - 1) `quot` w w = Table.width tbl -- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget' sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1 relational-query-0.9.5.1/src/Database/Relational/Query/Pi.hs0000644000000000000000000000230413206454105021744 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Pi -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed projection path objects. -- Contains normal interfaces. module Database.Relational.Query.Pi ( -- * Projection path Pi, pfmap, pap, pzero, (<.>), (), (), id', fst', snd' ) where import qualified Control.Category as Category import Database.Record (PersistableWidth, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Database.Relational.Query.Pi.Unsafe (Pi, pfmap, pap, pzero, (<.>), (), (), definePi) -- | Identity projection path. id' :: Pi a a id' = Category.id -- | Projection path for fst of tuple. fst' :: PersistableWidth a => Pi (a, b) a -- ^ Projection path of fst. fst' = definePi 0 snd'' :: PersistableWidth b => PersistableRecordWidth a -> Pi (a, b) b snd'' wa = definePi (runPersistableRecordWidth wa) -- | Projection path for snd of tuple. snd' :: (PersistableWidth a, PersistableWidth b) => Pi (a, b) b -- ^ Projection path of snd. snd' = snd'' persistableWidth relational-query-0.9.5.1/src/Database/Relational/Query/Monad/0000755000000000000000000000000013206454105022077 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Assign.hs0000644000000000000000000000343413206454105023663 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Assign -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about restrict context with assignment monad type. module Database.Relational.Query.Monad.Assign ( -- * Monad to restrict target records with assignment. Assign, AssignStatement, -- updateStatement, extract, ) where import Database.Relational.Query.Internal.BaseSQL (Assignment) import Database.Relational.Query.Internal.Config (Config) import Database.Relational.Query.Sub (QueryRestriction) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Table (Table) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Monad.Restrict (Restrict) import qualified Database.Relational.Query.Monad.Restrict as Restrict import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments) -- | Target update monad type used from update statement and merge statement. type Assign r = Assignings r Restrict -- | AssignStatement type synonym. -- Specifying assignments and restrictions like update statement. -- Projection record type must be -- the same as 'Target' type parameter 'r'. type AssignStatement r a = Projection Flat r -> Assign r a -- -- | 'return' of 'Update' -- updateStatement :: a -> Assignings r (Restrictings Identity) a -- updateStatement = assignings . restrictings . Identity -- | Run 'Assign'. extract :: Assign r a -> Config -> ((a, Table r -> [Assignment]), QueryRestriction Flat) extract = Restrict.extract . extractAssignments relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Unique.hs0000644000000000000000000000475613206454105023715 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.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.Query.Monad.Unique ( QueryUnique, unsafeUniqueSubQuery, toSubQuery, ) where import Control.Applicative (Applicative) import Database.Relational.Query.Internal.BaseSQL (Duplication) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.Class (MonadQualify, MonadQuery) import Database.Relational.Query.Monad.Trans.Join (unsafeSubQueryWithAttr) import Database.Relational.Query.Monad.Trans.Restricting (restrictings) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Query.Monad.Type (QueryCore, extractCore) import Database.Relational.Query.Sub (SubQuery, QueryRestriction, Qualified, JoinProduct, NodeAttr, flatSubQuery) -- | Unique query monad type. newtype QueryUnique a = QueryUnique (QueryCore a) deriving (MonadQualify ConfigureQuery, MonadQuery, Monad, Applicative, Functor) -- | Unsafely join sub-query with this unique query. unsafeUniqueSubQuery :: NodeAttr -- ^ Attribute maybe or just -> Qualified SubQuery -- ^ 'SubQuery' to join -> QueryUnique (Projection c r) -- ^ Result joined context and 'SubQuery' result projection. unsafeUniqueSubQuery a = QueryUnique . restrictings . unsafeSubQueryWithAttr a extract :: QueryUnique a -> ConfigureQuery (((a, QueryRestriction Flat), JoinProduct), Duplication) extract (QueryUnique c) = extractCore c -- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. toSubQuery :: QueryUnique (PlaceHolders p, Projection c r) -- ^ 'QueryUnique' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation toSubQuery q = do ((((_ph, pj), rs), pd), da) <- extract q c <- askConfig return $ flatSubQuery c (Projection.untype pj) da pd rs [] relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Register.hs0000644000000000000000000000202413206454105024215 0ustar0000000000000000-- | -- Module : Database.Relational.Query.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.Query.Monad.Register ( -- * Monad to register target records. Register, extract, ) where import Database.Relational.Query.Internal.BaseSQL (Assignment) import Database.Relational.Query.Internal.Config (Config) import Database.Relational.Query.Table (Table) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, configureQuery) import Database.Relational.Query.Monad.Trans.Assigning (Assignings, extractAssignments) -- | 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.9.5.1/src/Database/Relational/Query/Monad/BaseType.hs0000644000000000000000000000670213206454105024154 0ustar0000000000000000-- | -- Module : Database.Relational.Query.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.Query.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.Query.Internal.Config (Config, defaultConfig) import Database.Relational.Query.Internal.SQL (StringSQL, showStringSQL) import Database.Relational.Query.Sub (Qualified, SubQuery, showSQL, width) import qualified Database.Relational.Query.Monad.Trans.Qualify as Qualify import Database.Relational.Query.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) import Database.Relational.Query.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig) -- | Thin monad type for untyped structure. type ConfigureQuery = Qualify (QueryConfig Identity) -- | Run 'ConfigureQuery' monad with initial state to get only result. configureQuery :: ConfigureQuery q -> Config -> q configureQuery cq c = runIdentity $ runQueryConfig (evalQualifyPrime cq) c -- | Get qualifyed table form query. qualifyQuery :: a -> ConfigureQuery (Qualified a) qualifyQuery = Qualify.qualifyQuery -- | Read configuration. askConfig :: ConfigureQuery Config askConfig = qualify askQueryConfig -- | Relation type with place-holder parameter 'p' and query result type 'r'. newtype Relation p r = SubQuery (ConfigureQuery SubQuery) -- | Unsafely type qualified subquery into record typed relation type. unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r unsafeTypeRelation = SubQuery -- | Sub-query Qualify monad from relation. untypeRelation :: Relation p r -> ConfigureQuery SubQuery untypeRelation (SubQuery qsub) = qsub -- | '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.9.5.1/src/Database/Relational/Query/Monad/Aggregate.hs0000644000000000000000000001031113206454105024315 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.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.Query.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.Query.Internal.BaseSQL (Duplication, OrderingTerm, composeOrderBy) import Database.Relational.Query.Internal.GroupingSQL (AggregateColumnRef, AggregateElem, composePartitionBy) import Database.Relational.Query.Context (Flat, Aggregated, OverWindow) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Sub (SubQuery, QueryRestriction, JoinProduct, aggregatedSubQuery) import qualified Database.Relational.Query.Sub as SubQuery import Database.Relational.Query.Projectable (PlaceHolders, SqlProjectable) import Database.Relational.Query.Monad.Class (MonadRestrict(..)) import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, restrictings, extractRestrict) import Database.Relational.Query.Monad.Trans.Aggregating (extractAggregateTerms, AggregatingSetT, PartitioningSet) import Database.Relational.Query.Monad.Trans.Ordering (Orderings, extractOrderingTerms) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Query.Monad.Type (QueryCore, extractCore, OrderedQuery) -- | Aggregated query monad type. type QueryAggregate = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) -- | Aggregated query type. 'AggregatedQuery' p r == 'QueryAggregate' ('PlaceHolders' p, 'Projection' 'Aggregated' r). type AggregatedQuery p r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) p r -- | Partition monad type for partition-by clause. type Window c = Orderings c (PartitioningSet c) -- | Restricted 'MonadRestrict' instance. instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where restrict = restrictings . restrict extract :: AggregatedQuery p r -> ConfigureQuery (((((((PlaceHolders p, Projection Aggregated r), [OrderingTerm]), QueryRestriction Aggregated), [AggregateElem]), QueryRestriction Flat), JoinProduct), Duplication) extract = extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms -- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation. toSQL :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run -> ConfigureQuery String -- ^ Result SQL string with 'ConfigureQuery' computation toSQL = fmap SubQuery.toSQL . toSubQuery -- | Run 'AggregatedQuery' to get 'SubQuery' with 'ConfigureQuery' computation. toSubQuery :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation toSubQuery q = do (((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q c <- askConfig return $ aggregatedSubQuery c (Projection.untype pj) da pd rs ag grs ot extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef]) extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms -- | Operator to make window function result projection using built 'Window' monad. over :: SqlProjectable (Projection c) => Projection OverWindow a -> Window c () -> Projection c a wp `over` win = Projection.unsafeFromSqlTerms [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot) | c <- Projection.columns wp ] where (((), ot), pt) = extractWindow win infix 8 `over` relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Type.hs0000644000000000000000000000302513206454105023354 0ustar0000000000000000-- | -- Module : Database.Relational.Query.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.Query.Monad.Type ( -- * Core query monad QueryCore, extractCore, OrderedQuery, ) where import Database.Relational.Query.Internal.BaseSQL (Duplication) import Database.Relational.Query.Sub (JoinProduct, QueryRestriction) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.BaseType (ConfigureQuery) import Database.Relational.Query.Monad.Trans.Join (QueryJoin, extractProduct) import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict) import Database.Relational.Query.Monad.Trans.Ordering (Orderings) -- | Core query monad type used from flat(not-aggregated) query and aggregated query. type QueryCore = Restrictings Flat (QueryJoin ConfigureQuery) -- | Extract 'QueryCore' computation. extractCore :: QueryCore a -> ConfigureQuery (((a, QueryRestriction Flat), JoinProduct), Duplication) extractCore = extractProduct . extractRestrict -- | OrderedQuery monad type with placeholder type 'p'. Projection must be the same as 'Orderings' context type parameter 'c'. type OrderedQuery c m p r = Orderings c m (PlaceHolders p, Projection c r) relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Simple.hs0000644000000000000000000000516313206454105023671 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.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.Query.Monad.Simple ( -- * Simple query QuerySimple, SimpleQuery, simple, toSQL, toSubQuery, ) where import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Internal.BaseSQL (Duplication, OrderingTerm) import Database.Relational.Query.Monad.Trans.Join (join') import Database.Relational.Query.Monad.Trans.Restricting (restrictings) import Database.Relational.Query.Monad.Trans.Ordering (Orderings, orderings, extractOrderingTerms) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, askConfig) import Database.Relational.Query.Monad.Type (QueryCore, extractCore, OrderedQuery) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Sub (SubQuery, QueryRestriction, JoinProduct, flatSubQuery) import qualified Database.Relational.Query.Sub as SubQuery -- | Simple (not-aggregated) query monad type. type QuerySimple = Orderings Flat QueryCore -- | Simple (not-aggregated) query type. 'SimpleQuery'' p r == 'QuerySimple' ('PlaceHolders' p, 'Projection' r). type SimpleQuery p r = OrderedQuery Flat QueryCore p r -- | Lift from qualified table forms into 'QuerySimple'. simple :: ConfigureQuery a -> QuerySimple a simple = orderings . restrictings . join' extract :: SimpleQuery p r -> ConfigureQuery (((((PlaceHolders p, Projection Flat r), [OrderingTerm]), QueryRestriction Flat), JoinProduct), Duplication) extract = extractCore . extractOrderingTerms -- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation. toSQL :: SimpleQuery p r -- ^ 'SimpleQuery' to run -> ConfigureQuery String -- ^ Result SQL string with 'Qualify' computation toSQL = fmap SubQuery.toSQL . toSubQuery -- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. toSubQuery :: SimpleQuery p r -- ^ 'SimpleQuery'' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation toSubQuery q = do (((((_ph, pj), ot), rs), pd), da) <- extract q c <- askConfig return $ flatSubQuery c (Projection.untype pj) da pd rs ot relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Class.hs0000644000000000000000000000753413206454105023511 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.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.Query.Monad.Class ( -- * Query interface classes MonadQualify (..), MonadRestrict (..), MonadQuery (..), MonadAggregate (..), MonadPartition (..), all', distinct, on, wheres, having, ) where import Database.Relational.Query.Internal.BaseSQL (Duplication (..)) import Database.Relational.Query.Internal.GroupingSQL (AggregateKey) import Database.Relational.Query.Context (Flat, Aggregated) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Projectable (PlaceHolders) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, Relation) -- | Restrict context interface class (Functor m, Monad m) => MonadRestrict c m where -- | Add restriction to this context. restrict :: Projection c (Maybe Bool) -- ^ 'Projection' which represent restriction -> m () -- ^ Restricted query context -- | Query building interface. class (Functor m, Monad m, MonadQualify ConfigureQuery m) => MonadQuery m where -- | Specify duplication. setDuplication :: Duplication -> m () -- | Add restriction to last join. restrictJoin :: Projection Flat (Maybe Bool) -- ^ 'Projection' which represent restriction -> m () -- ^ Restricted query context {- Haddock BUG? -} -- | Join sub-query with place-holder parameter 'p'. query result is not 'Maybe'. query' :: Relation p r -> m (PlaceHolders p, Projection Flat r) -- | Join sub-query with place-holder parameter 'p'. Query result is 'Maybe'. queryMaybe' :: Relation p r -> m (PlaceHolders p, Projection Flat (Maybe r)) -- | Lift interface from base qualify monad. class (Functor q, Monad q, Functor m, Monad m) => MonadQualify q m where -- | Lift from qualify monad 'q' into 'MonadQuery' m. -- Qualify monad qualifies table form 'SubQuery'. liftQualify :: q a -> m a instance (Functor q, Monad q) => MonadQualify q q where liftQualify = id -- | Aggregated query building interface extends 'MonadQuery'. class MonadQuery m => MonadAggregate m where -- | Add /GROUP BY/ term into context and get aggregated projection. groupBy :: Projection Flat r -- ^ Projection to add into group by -> m (Projection Aggregated r) -- ^ Result context and aggregated projection -- | Add /GROUP BY/ term into context and get aggregated projection. Non-traditional group-by version. groupBy' :: AggregateKey (Projection Aggregated r) -- ^ Key to aggretate for non-traditional group-by interface -> m (Projection Aggregated r) -- ^ Result context and aggregated projection -- | Window specification building interface. class Monad m => MonadPartition c m where -- | Add /PARTITION BY/ term into context. partitionBy :: Projection c r -> m () -- | Specify ALL attribute to query context. all' :: MonadQuery m => m () all' = setDuplication All -- | Specify DISTINCT attribute to query context. distinct :: MonadQuery m => m () distinct = setDuplication Distinct -- | Add restriction to last join. Projection type version. on :: MonadQuery m => Projection Flat (Maybe Bool) -> m () on = restrictJoin -- | Add restriction to this not aggregated query. wheres :: MonadRestrict Flat m => Projection Flat (Maybe Bool) -> m () wheres = restrict -- | Add restriction to this aggregated query. Aggregated Projection type version. having :: MonadRestrict Aggregated m => Projection Aggregated (Maybe Bool) -> m () having = restrict relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Restrict.hs0000644000000000000000000000301613206454105024232 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Restrict -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains definitions about simple restrict context monad type. module Database.Relational.Query.Monad.Restrict ( -- * Monad to restrict target records. Restrict, RestrictedStatement, -- restricted, extract ) where import Database.Relational.Query.Internal.Config (Config) import Database.Relational.Query.Sub (QueryRestriction) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Projection (Projection) import Database.Relational.Query.Monad.Trans.Restricting (Restrictings, extractRestrict) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, configureQuery) -- | Restrict only monad type used from update statement and delete statement. type Restrict = Restrictings Flat ConfigureQuery -- | RestrictedStatement type synonym. -- Projection record type 'r' must be -- the same as 'Restrictings' type parameter 'r'. type RestrictedStatement r a = Projection Flat r -> Restrict a -- -- | 'return' of 'Restrict' -- restricted :: a -> Restrict a -- restricted = restrict . Identity -- | Run 'Restrict' to get 'QueryRestriction'. extract :: Restrict a -> Config -> (a, QueryRestriction Flat) extract = configureQuery . extractRestrict relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/0000755000000000000000000000000013206454105023166 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/Aggregating.hs0000644000000000000000000001450713206454105025750 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Aggregating -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift -- from 'MonadQuery' into Aggregated query. module Database.Relational.Query.Monad.Trans.Aggregating ( -- * Transformer into aggregated query Aggregatings, aggregatings, AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT, -- * Result extractAggregateTerms, -- * Grouping sets support AggregatingSet, AggregatingPowerSet, AggregatingSetList, PartitioningSet, key, key', set, bkey, rollup, cube, groupingSets, ) where import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) import Control.Arrow (second) import Data.DList (DList, toList) import Data.Functor.Identity (Identity (runIdentity)) import Database.Relational.Query.Internal.GroupingSQL (AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets, AggregateKey, aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey) import Database.Relational.Query.Context (Flat, Aggregated, Set, Power, SetList) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) -- | Type to accumulate aggregating context. -- Type 'ac' is aggregating-context type like aggregating key set building, -- aggregating key sets set building and partition key set building. -- Type 'at' is aggregating term type. newtype Aggregatings ac at m a = Aggregatings (WriterT (DList at) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Aggregatings'. aggregatings :: Monad m => m a -> Aggregatings ac at m a aggregatings = lift -- | Context type building one grouping set. type AggregatingSetT = Aggregatings Set AggregateElem -- | Context type building grouping sets list. type AggregatingSetListT = Aggregatings SetList AggregateSet -- | Context type building power group set. type AggregatingPowerSetT = Aggregatings Power AggregateBitKey -- | Context type building partition keys set. type PartitioningSetT c = Aggregatings c AggregateColumnRef -- | Aggregated 'MonadRestrict'. instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where restrict = aggregatings . restrict -- | Aggregated 'MonadQualify'. instance MonadQualify q m => MonadQualify q (AggregatingSetT m) where liftQualify = aggregatings . liftQualify -- | Aggregated 'MonadQuery'. instance MonadQuery m => MonadQuery (AggregatingSetT m) where setDuplication = aggregatings . setDuplication restrictJoin = aggregatings . restrictJoin query' = aggregatings . query' queryMaybe' = aggregatings . queryMaybe' unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m () unsafeAggregateWithTerm = Aggregatings . tell . pure aggregateKey :: Monad m => AggregateKey a -> Aggregatings ac AggregateElem m a aggregateKey k = do unsafeAggregateWithTerm $ aggregateKeyElement k return $ aggregateKeyProjection k -- | Aggregated query instance. instance MonadQuery m => MonadAggregate (AggregatingSetT m) where groupBy p = do mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p] return $ Projection.unsafeToAggregated p groupBy' = aggregateKey -- | Partition clause instance instance Monad m => MonadPartition c (PartitioningSetT c m) where partitionBy = mapM_ unsafeAggregateWithTerm . Projection.columns -- | Run 'Aggregatings' to get terms list. extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, [at]) extractAggregateTerms (Aggregatings ac) = second toList <$> runWriterT ac extractTermList :: Aggregatings ac at Identity a -> (a, [at]) extractTermList = runIdentity . extractAggregateTerms -- | Context monad type to build single grouping set. type AggregatingSet = AggregatingSetT Identity -- | Context monad type to build grouping power set. type AggregatingPowerSet = AggregatingPowerSetT Identity -- | Context monad type to build grouping set list. type AggregatingSetList = AggregatingSetListT Identity -- | Context monad type to build partition keys set. type PartitioningSet c = PartitioningSetT c Identity -- | Specify key of single grouping set from Projection. key :: Projection Flat r -> AggregatingSet (Projection Aggregated (Maybe r)) key p = do mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Projection.columns p] return . Projection.just $ Projection.unsafeToAggregated p -- | Specify key of single grouping set. key' :: AggregateKey a -> AggregatingSet a key' = aggregateKey -- | Finalize and specify single grouping set. set :: AggregatingSet a -> AggregatingSetList a set s = do let (p, c) = second aggregateGroupingSet . extractTermList $ s unsafeAggregateWithTerm c return p -- | Specify key of rollup and cube power set. bkey :: Projection Flat r -> AggregatingPowerSet (Projection Aggregated (Maybe r)) bkey p = do unsafeAggregateWithTerm . aggregatePowerKey $ Projection.columns p return . Projection.just $ Projection.unsafeToAggregated p finalizePower :: ([AggregateBitKey] -> AggregateElem) -> AggregatingPowerSet a -> AggregateKey a finalizePower finalize pow = unsafeAggregateKey . second finalize . extractTermList $ pow -- | Finalize grouping power set as rollup power set. rollup :: AggregatingPowerSet a -> AggregateKey a rollup = finalizePower aggregateRollup -- | Finalize grouping power set as cube power set. cube :: AggregatingPowerSet a -> AggregateKey a cube = finalizePower aggregateCube -- | Finalize grouping set list. groupingSets :: AggregatingSetList a -> AggregateKey a groupingSets = unsafeAggregateKey . second aggregateSets . extractTermList relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/Ordering.hs0000644000000000000000000001061213206454105025273 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Ordering -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift -- from query into query with ordering. module Database.Relational.Query.Monad.Trans.Ordering ( -- * Transformer into query with ordering Orderings, orderings, -- * 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.Query.Internal.BaseSQL (Order (..), Nulls (..), OrderColumn, OrderingTerm) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) -- | Type to accumulate ordering context. -- Type 'c' is ordering term projection context type. newtype Orderings c m a = Orderings (WriterT (DList OrderingTerm) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Orderings'. orderings :: Monad m => m a -> Orderings c m a orderings = lift -- | 'MonadRestrict' with ordering. instance MonadRestrict rc m => MonadRestrict rc (Orderings c m) where restrict = orderings . restrict -- | 'MonadQualify' with ordering. instance MonadQualify q m => MonadQualify q (Orderings c m) where liftQualify = orderings . liftQualify -- | 'MonadQuery' with ordering. instance MonadQuery m => MonadQuery (Orderings c m) where setDuplication = orderings . setDuplication restrictJoin = orderings . restrictJoin query' = orderings . query' queryMaybe' = orderings . queryMaybe' -- | 'MonadAggregate' with ordering. instance MonadAggregate m => MonadAggregate (Orderings c m) where groupBy = orderings . groupBy groupBy' = orderings . groupBy' -- | 'MonadPartition' with ordering. instance MonadPartition c m => MonadPartition c (Orderings c m) where partitionBy = orderings . partitionBy -- | Ordering term projection type interface. class ProjectableOrdering p where orderTerms :: p t -> [OrderColumn] -- | 'Projection' is ordering term. instance ProjectableOrdering (Projection c) where orderTerms = Projection.columns -- | Add ordering terms. updateOrderBys :: (Monad m, ProjectableOrdering (Projection c)) => (Order, Maybe Nulls) -- ^ Order direction -> Projection 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` orderTerms p -- | Add ordering terms with null ordering. orderBy' :: (Monad m, ProjectableOrdering (Projection c)) => Projection 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, ProjectableOrdering (Projection c)) => Projection 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, ProjectableOrdering (Projection c)) => Projection c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering asc = updateOrderBys (Asc, Nothing) -- | Add descendant ordering term. desc :: (Monad m, ProjectableOrdering (Projection c)) => Projection c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering desc = updateOrderBys (Desc, 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.9.5.1/src/Database/Relational/Query/Monad/Trans/Assigning.hs0000644000000000000000000000557313206454105025456 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Assigning -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines monad transformer which lift -- from context into context with assigning. module Database.Relational.Query.Monad.Trans.Assigning ( -- * Transformer into context with assignments Assignings, assignings, -- * API of context with assignments assignTo, (<-#), AssignTarget, -- * Result SQL set clause extractAssignments ) where import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) import Control.Arrow (second) import Data.Monoid (mconcat) import Data.DList (DList, toList) import Database.Relational.Query.Internal.BaseSQL (Assignment) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Pi (Pi) import Database.Relational.Query.Table (Table, recordWidth) import Database.Relational.Query.Projection (Projection) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..)) -- | Type to accumulate assigning context. -- Type 'r' is table record type. newtype Assignings r m a = Assignings (WriterT (Table r -> DList Assignment) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Assignings' assignings :: Monad m => m a -> Assignings r m a assignings = lift -- | 'MonadRestrict' with assigning. instance MonadRestrict c m => MonadRestrict c (Assignings r m) where restrict = assignings . restrict -- | 'MonadQualify' with assigning. instance MonadQualify q m => MonadQualify q (Assignings r m) where liftQualify = assignings . liftQualify -- | Target of assignment. type AssignTarget r v = Pi r v targetProjection :: AssignTarget r v -> Table r -> Projection Flat v targetProjection pi' tbl = Projection.wpi (recordWidth tbl) (Projection.unsafeFromTable tbl) pi' -- | Add an assignment. assignTo :: Monad m => Projection Flat v -> AssignTarget r v -> Assignings r m () assignTo vp target = Assignings . tell $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where leftsR = Projection.columns . targetProjection target rights = Projection.columns vp -- | Add and assginment. (<-#) :: Monad m => AssignTarget r v -> Projection Flat v -> Assignings r m () (<-#) = flip assignTo infix 4 <-# -- | Run 'Assignings' to get 'Assignments' extractAssignments :: (Monad m, Functor m) => Assignings r m a -> m (a, Table r -> [Assignment]) extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/Restricting.hs0000644000000000000000000000501513206454105026020 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.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.Query.Monad.Trans.Restricting ( -- * Transformer into restricted context Restrictings, restrictings, -- * Result extractRestrict ) where import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, pure, (<$>)) import Control.Arrow (second) import Data.DList (DList, toList) import Database.Relational.Query.Sub (QueryRestriction, Projection) import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) -- | Type to accumulate query restrictions. -- Type 'c' is context tag of restriction building like -- Flat (where) or Aggregated (having). newtype Restrictings c m a = Restrictings (WriterT (DList (Projection c (Maybe Bool))) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Restrictings' restrictings :: Monad m => m a -> Restrictings c m a restrictings = lift -- | Add whole query restriction. updateRestriction :: Monad m => Projection c (Maybe Bool) -> Restrictings c m () updateRestriction = Restrictings . tell . pure -- | 'MonadRestrict' instance. instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where restrict = updateRestriction -- | Restricted 'MonadQualify' instance. instance MonadQualify q m => MonadQualify q (Restrictings c m) where liftQualify = restrictings . liftQualify -- | Restricted 'MonadQuery' instance. instance MonadQuery q => MonadQuery (Restrictings c q) where setDuplication = restrictings . setDuplication restrictJoin = restrictings . restrictJoin query' = restrictings . query' queryMaybe' = restrictings . queryMaybe' -- | Resticted 'MonadAggregate' instance. instance MonadAggregate m => MonadAggregate (Restrictings c m) where groupBy = restrictings . groupBy groupBy' = restrictings . groupBy' -- | Run 'Restrictings' to get 'QueryRestriction' extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, QueryRestriction c) extractRestrict (Restrictings rc) = second toList <$> runWriterT rc relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/Config.hs0000644000000000000000000000236713206454105024737 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.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.Query.Monad.Trans.Config ( -- * Transformer into query with configuration QueryConfig, queryConfig, runQueryConfig, askQueryConfig ) where import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Control.Applicative (Applicative) import Database.Relational.Query.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.9.5.1/src/Database/Relational/Query/Monad/Trans/Qualify.hs0000644000000000000000000000322713206454105025140 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Qualify -- Copyright : 2013-2017 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.Query.Monad.Trans.Qualify ( -- * Qualify monad Qualify, qualify, evalQualifyPrime, qualifyQuery ) where import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT, runStateT, get, modify) import Control.Applicative (Applicative) import Control.Monad (liftM, ap) import qualified Database.Relational.Query.Internal.Sub as Internal -- | 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 Internal.Qualifier newAlias = Qualify $ do ai <- Internal.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 (Internal.Qualified query) -- ^ Result with updated state qualifyQuery query = Internal.qualify `liftM` newAlias `ap` return query relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/Join.hs0000644000000000000000000001020513206454105024417 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Relational.Query.Monad.Trans.Join -- Copyright : 2013-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.Query.Monad.Trans.Join ( -- * Transformer into join query QueryJoin, join', -- * Result extractProduct, -- * Unsafe API unsafeSubQueryWithAttr, ) where import Prelude hiding (product) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Monad.Trans.State (modify, StateT, runStateT) import Control.Applicative (Applicative, (<$>)) import Control.Arrow (second, (***)) import Data.Maybe (fromMaybe) import Data.Monoid (Last (Last, getLast)) import Database.Relational.Query.Internal.BaseSQL (Duplication (All)) import Database.Relational.Query.Internal.Product (restrictProduct, growProduct) import Database.Relational.Query.Sub (NodeAttr (Just', Maybe), SubQuery, Qualified, JoinProduct, Projection) import Database.Relational.Query.Context (Flat) import Database.Relational.Query.Monad.Trans.JoinState (JoinContext, primeJoinContext, updateProduct, joinProduct) import qualified Database.Relational.Query.Projection as Projection import Database.Relational.Query.Projectable (PlaceHolders, unsafeAddPlaceHolders) import Database.Relational.Query.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, untypeRelation) import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadQuery (..)) -- | 'StateT' type to accumulate join product context. newtype QueryJoin m a = QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a) deriving (Monad, Functor, Applicative) instance MonadTrans QueryJoin where lift = QueryJoin . lift . lift -- | Lift to 'QueryJoin' join' :: Monad m => m a -> QueryJoin m a join' = lift -- | Unsafely update join product context. updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m () updateContext = QueryJoin . modify -- | Add last join product restriction. updateJoinRestriction :: Monad m => Projection Flat (Maybe Bool) -> QueryJoin m () updateJoinRestriction e = updateContext (updateProduct d) where d Nothing = error "on: Product is empty! Restrict target product is not found!" d (Just pt) = restrictProduct pt e instance MonadQualify q m => MonadQualify q (QueryJoin m) where liftQualify = join' . liftQualify -- | Joinable query instance. instance MonadQuery (QueryJoin ConfigureQuery) where setDuplication = QueryJoin . lift . tell . Last . Just restrictJoin = updateJoinRestriction query' = queryWithAttr Just' queryMaybe' pr = do (ph, pj) <- queryWithAttr Maybe pr return (ph, Projection.just pj) -- | Unsafely join sub-query with this query. unsafeSubQueryWithAttr :: Monad q => NodeAttr -- ^ Attribute maybe or just -> Qualified SubQuery -- ^ 'SubQuery' to join -> QueryJoin q (Projection c r) -- ^ Result joined context and 'SubQuery' result projection. unsafeSubQueryWithAttr attr qsub = do updateContext (updateProduct (`growProduct` (attr, qsub))) return $ Projection.unsafeFromQualifiedSubQuery qsub -- | Basic monadic join operation using 'MonadQuery'. queryWithAttr :: NodeAttr -> Relation p r -> QueryJoin ConfigureQuery (PlaceHolders p, Projection c r) queryWithAttr attr = unsafeAddPlaceHolders . run where run rel = do q <- liftQualify $ do sq <- untypeRelation rel qualifyQuery sq unsafeSubQueryWithAttr attr q -- | Run 'QueryJoin' to get 'JoinProduct' extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication) extractProduct (QueryJoin s) = (second joinProduct *** (fromMaybe All . getLast)) <$> runWriterT (runStateT s primeJoinContext) relational-query-0.9.5.1/src/Database/Relational/Query/Monad/Trans/JoinState.hs0000644000000000000000000000241113206454105025420 0ustar0000000000000000-- | -- Module : Database.Relational.Query.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.Query.Monad.Trans.Join". -- -- This is not public interface. module Database.Relational.Query.Monad.Trans.JoinState ( -- * Join context JoinContext, primeJoinContext, updateProduct, joinProduct ) where import Prelude hiding (product) import Data.DList (toList) import Database.Relational.Query.Internal.Sub (ProductBuilder, JoinProduct) import qualified Database.Relational.Query.Internal.Sub as Product -- | JoinContext type for QueryJoin. newtype JoinContext = JoinContext { product :: Maybe ProductBuilder } -- | Initial 'JoinContext'. primeJoinContext :: JoinContext primeJoinContext = JoinContext Nothing -- | Update product of 'JoinContext'. updateProduct :: (Maybe ProductBuilder -> ProductBuilder) -> JoinContext -> JoinContext updateProduct uf ctx = ctx { product = Just . uf . product $ ctx } -- | Finalize context to extract accumulated query product. joinProduct :: JoinContext -> JoinProduct joinProduct = fmap (fmap toList . Product.nodeTree) . product relational-query-0.9.5.1/src/Database/Relational/Query/Pi/0000755000000000000000000000000013206454105021411 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/Query/Pi/Unsafe.hs0000644000000000000000000001436313206454105023175 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.Relational.Query.Pi.Unsafe -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines typed projection path objects. -- Contains internal structure and unsafe interfaces. module Database.Relational.Query.Pi.Unsafe ( -- * Projection path Pi, pfmap, pap, pzero, width', width, (<.>), (), (), pi, definePi, defineDirectPi', defineDirectPi, unsafeExpandIndexes', unsafeExpandIndexes ) where import Prelude hiding (pi, (.), id) import Control.Category (Category (..), (>>>)) import Data.Array (listArray, (!)) import Database.Record.Persistable (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, (<&>), PersistableWidth (persistableWidth), maybeWidth) import Database.Relational.Query.ProjectableClass (ProductConstructor (..), ProjectableFunctor (..), ProjectableApplicative (..), ) -- | 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) -- | Unsafely untype key to expand indexes. unsafeExpandIndexes' :: PersistableRecordWidth a -> Pi a b -> [Int] unsafeExpandIndexes' wa (Pi f) = d $ f wa where d (Map is, _) = is d (Leftest i, w) = [ i .. i + w' - 1 ] where w' = runPersistableRecordWidth w -- | Unsafely untype key to expand indexes. unsafeExpandIndexes :: PersistableWidth a => Pi a b -> [Int] unsafeExpandIndexes = unsafeExpandIndexes' persistableWidth -- | 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) -- | Projectable fmap of 'Pi' type. pfmap :: ProductConstructor (a -> b) => (a -> b) -> Pi r a -> Pi r b _ `pfmap` p = unsafeCast p -- | Projectable ap of 'Pi' type. pap :: Pi r (a -> b) -> Pi r a -> Pi r b pap pab pb = Pi $ \wr -> let (_, wab) = runPi pab wr (_, wb) = runPi pb wr in (Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb, unsafeCastRecordWidth $ wab <&> wb) {- should switch to safe projectable-applicative -} -- | Compose seed of projection path 'Pi' which has record result type. instance ProjectableFunctor (Pi a) where (|$|) = pfmap -- | Compose projection path 'Pi' which has record result type using applicative style. instance ProjectableApplicative (Pi a) where (|*|) = pap -- | 'Pi' with zero width which projects to unit pzero :: Pi a () pzero = Pi $ \_ -> (Map [], persistableWidth) -- | 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.9.5.1/src/Database/Relational/Query/Internal/0000755000000000000000000000000013206454105022615 5ustar0000000000000000relational-query-0.9.5.1/src/Database/Relational/Query/Internal/Product.hs0000644000000000000000000000426613206454105024601 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.Product -- 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.Query.Internal.Product ( -- * Interfaces to manipulate ProductTree type growProduct, restrictProduct, ) where import Prelude hiding (and, product) import Control.Applicative (pure) import Data.Monoid ((<>), mempty) import Database.Relational.Query.Internal.ContextType (Flat) import Database.Relational.Query.Internal.Sub (NodeAttr (..), ProductTree (..), Node (..), Projection, Qualified, SubQuery, ProductTreeBuilder, ProductBuilder) -- | Push new tree into product right term. growRight :: Maybe ProductBuilder -- ^ Current tree -> (NodeAttr, ProductTreeBuilder) -- ^ New tree to push into right -> ProductBuilder -- ^ Result node growRight = d where d Nothing (naR, q) = Node naR q d (Just l) (naR, q) = Node Just' $ Join l (Node naR q) mempty -- | Push new leaf node into product right term. growProduct :: Maybe ProductBuilder -- ^ Current tree -> (NodeAttr, Qualified SubQuery) -- ^ New leaf to push into right -> ProductBuilder -- ^ Result node growProduct = match where match t (na, q) = growRight t (na, Leaf q) -- | Add restriction into top product of product tree. restrictProduct' :: ProductTreeBuilder -- ^ Product to restrict -> Projection Flat (Maybe Bool) -- ^ Restriction to add -> ProductTreeBuilder -- ^ Result product restrictProduct' = d where d (Join lp rp rs) rs' = Join lp rp (rs <> pure rs') d leaf'@(Leaf _) _ = leaf' -- or error on compile -- | Add restriction into top product of product tree node. restrictProduct :: ProductBuilder -- ^ Target node which has product to restrict -> Projection Flat (Maybe Bool) -- ^ Restriction to add -> ProductBuilder -- ^ Result node restrictProduct (Node a t) e = Node a (restrictProduct' t e) relational-query-0.9.5.1/src/Database/Relational/Query/Internal/SQL.hs0000644000000000000000000000251113206454105023607 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Relational.Query.Internal.SQL -- Copyright : 2014-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides SQL string wrap interfaces. module Database.Relational.Query.Internal.SQL ( StringSQL, stringSQL, showStringSQL, rowStringSQL, rowPlaceHolderStringSQL, rowConsStringSQL, listStringSQL, ) where import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren) -- | String wrap type for SQL strings. type StringSQL = Keyword -- | 'StringSQL' from 'String'. stringSQL :: String -> StringSQL stringSQL = word -- | 'StringSQL' to 'String'. showStringSQL :: StringSQL -> String showStringSQL = wordShow -- | Row String of SQL values. rowStringSQL :: [StringSQL] -> StringSQL rowStringSQL = d where d [] = error "Projection: no columns." d [c] = c d cs = paren $ fold (|*|) cs -- | Place holder row String of SQL. rowPlaceHolderStringSQL :: Int -> StringSQL rowPlaceHolderStringSQL = rowStringSQL . (`replicate` stringSQL "?") -- | List String of SQL. rowConsStringSQL :: [StringSQL] -> StringSQL rowConsStringSQL = paren . fold (|*|) -- | List String of SQL. listStringSQL :: [StringSQL] -> StringSQL listStringSQL = paren . fold (|*|) relational-query-0.9.5.1/src/Database/Relational/Query/Internal/BaseSQL.hs0000644000000000000000000000574413206454105024415 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.BaseSQL -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides base structure of SQL syntax tree. module Database.Relational.Query.Internal.BaseSQL ( Duplication (..), showsDuplication, Order (..), Nulls (..), OrderColumn, OrderingTerm, composeOrderBy, AssignColumn, AssignTerm, Assignment, composeSets, composeChunkValues, composeChunkValuesWithColumns, ) where import Data.Monoid (Monoid (..), (<>)) import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Query.Internal.SQL (StringSQL, rowConsStringSQL) -- | Result record duplication attribute data Duplication = All | Distinct deriving Show -- | Compose duplication attribute string. showsDuplication :: Duplication -> StringSQL showsDuplication = dup where dup All = ALL dup Distinct = DISTINCT -- | Order direction. Ascendant or Descendant. data Order = Asc | Desc deriving Show -- | Order of null. data Nulls = NullsFirst | NullsLast deriving Show -- | Type for order-by column type OrderColumn = StringSQL -- | Type for order-by term type OrderingTerm = ((Order, Maybe Nulls), OrderColumn) -- | Compose ORDER BY clause from OrderingTerms composeOrderBy :: [OrderingTerm] -> StringSQL composeOrderBy = d where d [] = mempty d ts@(_:_) = ORDER <> BY <> SQL.fold (|*|) (map showsOt ts) showsOt ((o, mn), e) = e <> order o <> maybe mempty ((NULLS <>) . nulls) mn order Asc = ASC order Desc = DESC nulls NullsFirst = FIRST nulls NullsLast = LAST -- | 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 value expression list. composeChunkValues :: Int -- ^ record count per chunk -> [StringSQL] -- ^ 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 VALUES clause from value expression list. composeChunkValuesWithColumns :: Int -- ^ record count per chunk -> [Assignment] -- ^ -> StringSQL composeChunkValuesWithColumns sz as = rowConsStringSQL cs <> composeChunkValues sz vs where (cs, vs) = unzip as relational-query-0.9.5.1/src/Database/Relational/Query/Internal/GroupingSQL.hs0000644000000000000000000000726613206454105025336 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.GroupingSQL -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides grouping-sets structure of SQL syntax tree. module Database.Relational.Query.Internal.GroupingSQL ( AggregateColumnRef, AggregateBitKey (..), AggregateSet (..), AggregateElem (..), aggregateColumnRef, aggregateEmpty, aggregatePowerKey, aggregateGroupingSet, aggregateRollup, aggregateCube, aggregateSets, composeGroupBy, composePartitionBy, AggregateKey (..), aggregateKeyProjection, aggregateKeyElement, unsafeAggregateKey, ) where import Data.Monoid (Monoid (..), (<>)) import Language.SQL.Keyword (Keyword(..), (|*|)) import qualified Language.SQL.Keyword as SQL import Database.Relational.Query.Internal.SQL (StringSQL) -- | Type for group-by term type AggregateColumnRef = StringSQL -- | Type for group key. newtype AggregateBitKey = AggregateBitKey [AggregateColumnRef] deriving Show -- | Type for grouping set newtype AggregateSet = AggregateSet [AggregateElem] deriving Show -- | Type for group-by tree data AggregateElem = ColumnRef AggregateColumnRef | Rollup [AggregateBitKey] | Cube [AggregateBitKey] | GroupingSets [AggregateSet] deriving Show -- | Typeful aggregate element. newtype AggregateKey a = AggregateKey (a, AggregateElem) -- | Single term aggregation element. aggregateColumnRef :: AggregateColumnRef -> AggregateElem aggregateColumnRef = ColumnRef -- | Key of aggregation power set. aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey aggregatePowerKey = AggregateBitKey -- | Single grouping set. aggregateGroupingSet :: [AggregateElem] -> AggregateSet aggregateGroupingSet = AggregateSet -- | Rollup aggregation element. aggregateRollup :: [AggregateBitKey] -> AggregateElem aggregateRollup = Rollup -- | Cube aggregation element. aggregateCube :: [AggregateBitKey] -> AggregateElem aggregateCube = Cube -- | Grouping sets aggregation. aggregateSets :: [AggregateSet] -> AggregateElem aggregateSets = GroupingSets -- | Empty aggregation. aggregateEmpty :: [AggregateElem] aggregateEmpty = [] 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 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) = 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 ts -- | Extract typed projection from 'AggregateKey'. aggregateKeyProjection :: AggregateKey a -> a aggregateKeyProjection (AggregateKey (p, _c)) = p -- | Extract untyped term from 'AggregateKey'. aggregateKeyElement :: AggregateKey a -> AggregateElem aggregateKeyElement (AggregateKey (_p, c)) = c -- | Unsafely bind typed-projection and untyped-term into 'AggregateKey'. unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a unsafeAggregateKey = AggregateKey relational-query-0.9.5.1/src/Database/Relational/Query/Internal/Sub.hs0000644000000000000000000001571413206454105023712 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | -- Module : Database.Relational.Query.Internal.Sub -- Copyright : 2015-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines sub-query structure used in query products. module Database.Relational.Query.Internal.Sub ( SubQuery (..) , SetOp (..), BinOp (..), Qualifier (..) , Qualified (..), qualifier, unQualify, qualify -- * Product tree type , NodeAttr (..), ProductTree (..) , Node (..), nodeAttr, nodeTree , JoinProduct, QueryProductTree , ProductTreeBuilder, ProductBuilder , CaseClause (..), WhenClauses(..) , caseSearch, case' , UntypedProjection, untypedProjectionWidth, ProjectionUnit (..) , Projection, untypeProjection, typedProjection, projectionWidth , projectFromColumns, projectFromScalarSubQuery -- * Query restriction , QueryRestriction ) where import Prelude hiding (and, product) import Data.DList (DList) import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Database.Relational.Query.Internal.Config (Config) import Database.Relational.Query.Internal.ContextType (Flat, Aggregated) import Database.Relational.Query.Internal.SQL (StringSQL) import Database.Relational.Query.Internal.BaseSQL (Duplication (..), OrderingTerm) import Database.Relational.Query.Internal.GroupingSQL (AggregateElem) import Database.Relational.Query.Internal.UntypedTable (Untyped) -- | Set operators data SetOp = Union | Except | Intersect deriving Show -- | Set binary operators newtype BinOp = BinOp (SetOp, Duplication) deriving Show -- | Sub-query type data SubQuery = Table Untyped | Flat Config UntypedProjection Duplication JoinProduct (QueryRestriction Flat) [OrderingTerm] | Aggregated Config UntypedProjection Duplication JoinProduct (QueryRestriction Flat) [AggregateElem] (QueryRestriction 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 type QS = Qualified SubQuery type QueryRestrictionBuilder = DList (Projection Flat (Maybe Bool)) -- | Product tree type. Product tree is constructed by left node and right node. data ProductTree rs = Leaf QS | Join !(Node rs) !(Node rs) !rs deriving (Show, Functor) -- | Product node. node attribute and product tree. data Node rs = Node !NodeAttr !(ProductTree rs) deriving (Show, Functor) -- | Get node attribute. nodeAttr :: Node rs -> NodeAttr nodeAttr (Node a _) = a where -- | Get tree from node. nodeTree :: Node rs -> ProductTree rs nodeTree (Node _ t) = t -- | Product tree with join restriction. type QueryProductTree = ProductTree (QueryRestriction Flat) -- | Product tree with join restriction builder. type ProductTreeBuilder = ProductTree QueryRestrictionBuilder -- | Product noe with join restriction builder. type ProductBuilder = Node QueryRestrictionBuilder -- | Type for join product of query. type JoinProduct = Maybe QueryProductTree -- | when clauses data WhenClauses = WhenClauses [(UntypedProjection, UntypedProjection)] UntypedProjection deriving Show -- | case clause data CaseClause = CaseSearch WhenClauses | CaseSimple UntypedProjection WhenClauses deriving Show -- | Projection structure unit with single column width data ProjectionUnit = RawColumn 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 projection. Forgot record type. type UntypedProjection = [ProjectionUnit] -- | Width of 'UntypedProjection'. untypedProjectionWidth :: UntypedProjection -> Int untypedProjectionWidth = length -- | Phantom typed projection. Projected into Haskell record type 't'. newtype Projection c t = Projection { untypeProjection :: UntypedProjection {- ^ Discard projection value type -} } deriving Show -- | Unsafely type projection value. typedProjection :: UntypedProjection -> Projection c t typedProjection = Projection -- | Width of 'Projection'. projectionWidth :: Projection c r -> Int projectionWidth = length . untypeProjection -- | Unsafely generate 'Projection' from SQL string list. projectFromColumns :: [StringSQL] -- ^ SQL string list specifies columns -> Projection c r -- ^ Result 'Projection' projectFromColumns = typedProjection . map RawColumn -- | Unsafely generate 'Projection' from scalar sub-query. projectFromScalarSubQuery :: SubQuery -> Projection c t projectFromScalarSubQuery = typedProjection . (:[]) . Scalar whenClauses :: String -- ^ Error tag -> [(Projection c a, Projection c b)] -- ^ Each when clauses -> Projection c b -- ^ Else result projection -> WhenClauses -- ^ Result clause whenClauses eTag ws0 e = d ws0 where d [] = error $ eTag ++ ": Empty when clauses!" d ws@(_:_) = WhenClauses [ (untypeProjection p, untypeProjection r) | (p, r) <- ws ] $ untypeProjection e -- | Search case operator correnponding SQL search /CASE/. -- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ caseSearch :: [(Projection c (Maybe Bool), Projection c a)] -- ^ Each when clauses -> Projection c a -- ^ Else result projection -> Projection c a -- ^ Result projection caseSearch ws e = typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ] where c = CaseSearch $ whenClauses "caseSearch" ws e -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ case' :: Projection c a -- ^ Projection value to match -> [(Projection c a, Projection c b)] -- ^ Each when clauses -> Projection c b -- ^ Else result projection -> Projection c b -- ^ Result projection case' v ws e = typedProjection [ Case c i | i <- [0 .. projectionWidth e - 1] ] where c = CaseSimple (untypeProjection v) $ whenClauses "case'" ws e -- | Type for restriction of query. type QueryRestriction c = [Projection c (Maybe Bool)] relational-query-0.9.5.1/src/Database/Relational/Query/Internal/UntypedTable.hs0000644000000000000000000000230013206454105025544 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.UntypedTable -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines no-phantom table type which has table metadatas. module Database.Relational.Query.Internal.UntypedTable ( Untyped (Untyped), name', width', columns', (!), ) where import Data.Array (Array, elems) import qualified Data.Array as Array import Database.Relational.Query.Internal.SQL (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.9.5.1/src/Database/Relational/Query/Internal/ContextType.hs0000644000000000000000000000146613206454105025446 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Database.Relational.Query.Internal.ContextType -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines query context tag types. module Database.Relational.Query.Internal.ContextType ( Flat, Aggregated, Exists, OverWindow, Set, SetList, Power, ) where -- | Type tag for flat (not-aggregated) query data Flat -- | Type tag for aggregated query data Aggregated -- | Type tag for exists predicate data Exists -- | Type tag for window function building data OverWindow -- | Type tag for normal aggregatings set data Set -- | Type tag for aggregatings GROUPING SETS data SetList -- | Type tag for aggregatings power set data Power relational-query-0.9.5.1/src/Database/Relational/Query/Internal/Config.hs0000644000000000000000000000474513206454105024370 0ustar0000000000000000-- | -- Module : Database.Relational.Query.Internal.Config -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines configuration datatype used in query products. module Database.Relational.Query.Internal.Config ( NameConfig (..), ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), Config ( productUnitSupport , chunksInsertSize , schemaNameMode , normalizedTableName , verboseAsCompilerWarning , identifierQuotation , nameConfig), defaultConfig, ) where import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) import qualified Database.Record.TH as RecordTH -- | 'NameConfig' type to customize names of expanded templates. data NameConfig = NameConfig { recordConfig :: RecordTH.NameConfig , relationVarName :: String -> String -> VarName } instance Show NameConfig where show = const "" -- | Unit of product is supported or not. data ProductUnitSupport = PUSupported | PUNotSupported deriving Show -- | Schema name qualify mode in SQL string. data SchemaNameMode = SchemaQualified -- ^ Schema qualified table name in SQL string | SchemaNotQualified -- ^ Not qualified table name in SQL string deriving (Eq, Show) -- | Configuration for quotation of identifiers of SQL. data IdentifierQuotation = NoQuotation | Quotation Char deriving Show -- | Configuration type. data Config = Config { productUnitSupport :: !ProductUnitSupport , chunksInsertSize :: !Int , schemaNameMode :: !SchemaNameMode , normalizedTableName :: !Bool , verboseAsCompilerWarning :: !Bool , identifierQuotation :: !IdentifierQuotation , nameConfig :: !NameConfig } deriving Show -- | Default configuration. defaultConfig :: Config defaultConfig = Config { productUnitSupport = PUSupported , chunksInsertSize = 256 , schemaNameMode = SchemaQualified , normalizedTableName = True , verboseAsCompilerWarning = False , identifierQuotation = NoQuotation , nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig , relationVarName = const varCamelcaseName } } relational-query-0.9.5.1/test/0000755000000000000000000000000013206454105014326 5ustar0000000000000000relational-query-0.9.5.1/test/sqlsEq.hs0000644000000000000000000005704713206454105016147 0ustar0000000000000000 import Test.QuickCheck.Simple (Test, defaultMain) import qualified Test.QuickCheck.Simple as QSimple import Control.Applicative ((<$>), (<*>)) import Lex (eqProp, eqProp') import Model import Data.Int (Int32, Int64) import Database.Relational.Query tables :: [Test] tables = [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" , eqProp "setB" setB "SELECT int_b0, may_str_b1, str_b2 FROM TEST.set_b" , eqProp "setC" setC "SELECT int_c0, str_c1, int_c2, may_str_c3 FROM TEST.set_c" ] _p_tables :: IO () _p_tables = mapM_ print [show setA, show setB, show setC] -- Monadic Operators tests queryX :: Relation () SetA queryX = relation $ do a <- query setA return a queryMaybeX :: Relation () (Maybe SetA) queryMaybeX = relation $ do a <- queryMaybe setA return a onX :: Relation () (Maybe SetA, SetB) onX = relation $ do a <- queryMaybe setA b <- query setB on $ a ?! intA0' .=. just (b ! intB0') return $ (,) |$| a |*| b wheresX :: Relation () (SetA, SetB) wheresX = relation $ do a <- query setA b <- query setB wheres $ b ! intB0' .>=. value 3 return $ (,) |$| a |*| b groupByX :: Relation () (Int32, Integer) groupByX = aggregateRelation $ do a <- query setA ga0 <- groupBy $ a ! intA0' return $ (,) |$| ga0 |*| count (a ! intA0') havingX :: Relation () Int havingX = aggregateRelation $ do a <- query setA let c = count (a ! intA0') having $ c .>. value 1 return c distinctX :: Relation () Int32 distinctX = relation $ do distinct a <- query setA return $ a ! intA0' all'X :: Relation () Int32 all'X = relation $ do all' a <- query setA return $ a ! intA0' assignX :: Update () assignX = derivedUpdate $ \_proj -> do intA0' <-# value (0 :: Int32) return unitPlaceHolder registerX :: Insert (String, Maybe String) registerX = derivedInsertValue $ 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 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] -- Projection Operators bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r bin53 op = relation $ do return $ value 5 `op` value 3 strIn :: Relation () (Maybe Bool) strIn = relation $ return $ value "foo" `in'` values ["foo", "bar"] boolTF :: (Projection Flat (Maybe Bool) -> Projection Flat (Maybe Bool) -> Projection Flat r) -> Relation () r boolTF op = relation $ do return $ valueTrue `op` valueFalse strConcat :: Relation () String strConcat = relation $ do return $ value "Hello, " .||. value "World!" strLike :: Relation () (Maybe Bool) strLike = relation $ do return $ value "Hoge" `like` "H%" _p_bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO () _p_bin53 = print . bin53 bin :: [Test] bin = [ eqProp "equal" (bin53 (.=.)) "SELECT ALL (5 = 3) AS f0" , eqProp "lt" (bin53 (.<.)) "SELECT ALL (5 < 3) AS f0" , eqProp "le" (bin53 (.<=.)) "SELECT ALL (5 <= 3) AS f0" , eqProp "gt" (bin53 (.>.)) "SELECT ALL (5 > 3) AS f0" , eqProp "ge" (bin53 (.>=.)) "SELECT ALL (5 >= 3) AS f0" , eqProp "ne" (bin53 (.<>.)) "SELECT ALL (5 <> 3) AS f0" , eqProp "and" (boolTF and') "SELECT ALL ((0=0) AND (0=1)) AS f0" , eqProp "or" (boolTF or') "SELECT ALL ((0=0) OR (0=1)) AS f0" , eqProp "in" strIn "SELECT ALL ('foo' IN ('foo', 'bar')) AS f0" , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0" , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0" , eqProp "plus" (bin53 (.+.)) "SELECT ALL (5 + 3) AS f0" , eqProp "minus" (bin53 (.-.)) "SELECT ALL (5 - 3) AS f0" , eqProp "mult" (bin53 (.*.)) "SELECT ALL (5 * 3) AS f0" , eqProp "div" (bin53 (./.)) "SELECT ALL (5 / 3) AS f0" ] 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 notX :: Relation () (Maybe Bool) notX = relation $ return $ not' valueFalse existsX :: Relation () (Maybe Bool) existsX = relation $ return . exists =<< queryList setA uni :: [Test] uni = [ eqProp "isNothing" nothingX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) \ \ WHERE ((T1.int_b0 IS NULL) OR (T0.int_a0 = 1))" , eqProp "isJust" justX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, \ \ T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 \ \ FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) \ \ WHERE ((NOT (T1.int_b0 IS NULL)) OR (T0.int_a0 = 1))" , eqProp "fromMaybe" maybeX "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, \ \ T1.int_b0 AS f1, T1.may_str_b1 AS f2, T1.str_b2 AS f3 \ \ FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)" , eqProp "not" notX "SELECT ALL (NOT (0=1)) AS f0" , eqProp "exists" existsX "SELECT ALL (EXISTS (SELECT int_a0, str_a1, str_a2 FROM TEST.set_a)) AS f0" ] _p_uni :: IO () _p_uni = mapM_ print [show nothingX, show justX, show maybeX, show notX, show existsX] groupX :: Relation () (String, Int64) groupX = aggregateRelation $ do c <- query setC gc1 <- groupBy $ c ! strC1' return $ gc1 >< count (c ! intC0') cubeX :: Relation () ((Maybe String, Maybe (Int64, Maybe String)), Maybe Int32) cubeX = aggregateRelation $ do c <- query setC gCube <- groupBy' . cube $ do (><) <$> bkey (c ! strC1') <*> bkey (c ! intC2' >< c ! mayStrC3') return $ gCube >< sum' (c ! intC0') groupingSetsX :: Relation () (((Maybe String, Maybe (Maybe String)), Maybe Int64), Maybe Int64) groupingSetsX = aggregateRelation $ do c <- query setC gs <- groupBy' . groupingSets $ do s1 <- set $ do gRollup <- key' . rollup $ do (><) <$> bkey (c ! strC1') <*> bkey (c ! mayStrC3') gc2 <- key $ c ! intC2' return $ gRollup >< gc2 s2 <- set . key $ c ! intC2' return $ s1 >< s2 return gs groups :: [Test] groups = [ eqProp "group" groupX "SELECT ALL T0.str_c1 AS f0, COUNT(T0.int_c0) AS f1 \ \ FROM TEST.set_c T0 GROUP BY T0.str_c1" , eqProp "cube" cubeX "SELECT ALL T0.str_c1 AS f0, T0.int_c2 AS f1, T0.may_str_c3 AS f2, SUM(T0.int_c0) AS f3 \ \ FROM TEST.set_c T0 GROUP BY CUBE ((T0.str_c1), (T0.int_c2, T0.may_str_c3))" , eqProp "groupingSets" groupingSetsX "SELECT ALL T0.str_c1 AS f0, T0.may_str_c3 AS f1, T0.int_c2 AS f2, T0.int_c2 AS f3 \ \ FROM TEST.set_c T0 GROUP BY \ \ GROUPING SETS ((ROLLUP ((T0.str_c1), (T0.may_str_c3)), T0.int_c2), (T0.int_c2))" ] _p_groups :: IO () _p_groups = mapM_ print [show groupX, show cubeX, show groupingSetsX] ordFlatX :: Relation () (SetA, Maybe SetB) ordFlatX = relation $ do a <- query setA b <- queryMaybe setB on $ just (a ! strA2') .=. b ?! strB2' orderBy (a ! strA1') Asc orderBy' (b ?! mayStrB1') Desc 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 = derivedInsert id' insertI :: Insert SetI insertI = derivedInsert id' insertQueryX :: InsertQuery () insertQueryX = derivedInsertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = derivedUpdate $ \proj -> do strA2' <-# value "X" wheres $ proj ! strA1' .=. value "A" return unitPlaceHolder deleteX :: Delete () deleteX = derivedDelete $ \proj -> do wheres $ proj ! strA1' .=. value "A" return unitPlaceHolder effs :: [Test] effs = [ eqProp "insert" insertX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)" , 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 SET str_a2 = 'X' WHERE (str_a1 = 'A')" , eqProp "delete" deleteX "DELETE FROM TEST.set_a WHERE (str_a1 = 'A')" ] updateExistsX :: Update () updateExistsX = derivedUpdate $ \proj -> do strA2' <-# value "X" wheres . exists =<< (queryList . relation $ do b <- query setB wheres $ b ! intB0' .=. proj ! intA0' return b) return unitPlaceHolder updateScalarX :: Update () updateScalarX = derivedUpdate $ \proj -> do strA2' <-# value "X" sb <- queryScalar . unsafeUnique . relation $ do b <- query setB wheres $ b ! intB0' .=. value 0 return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb return unitPlaceHolder deleteExistsX :: Delete () deleteExistsX = derivedDelete $ \proj -> do wheres . exists =<< (queryList . relation $ do b <- query setB wheres $ b ! intB0' .=. proj ! intA0' return b) return unitPlaceHolder deleteScalarX :: Delete () deleteScalarX = derivedDelete $ \proj -> do sb <- queryScalar . unsafeUnique . relation $ do b <- query setB wheres $ b ! intB0' .=. value 0 return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb return unitPlaceHolder correlated :: [Test] correlated = [ eqProp "update-exists" updateExistsX "UPDATE TEST.set_a SET str_a2 = 'X' \ \ WHERE (EXISTS (SELECT ALL T0.int_b0 AS f0, T0.may_str_b1 AS f1, T0.str_b2 AS f2 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = int_a0)))" , eqProp "update-scalar" updateScalarX "UPDATE TEST.set_a SET str_a2 = 'X' \ \ WHERE (int_a0 = (SELECT ALL T0.int_b0 AS f0 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = 0)))" , eqProp "delete-exists" deleteExistsX "DELETE FROM TEST.set_a \ \ WHERE (EXISTS (SELECT ALL T0.int_b0 AS f0, T0.may_str_b1 AS f1, T0.str_b2 AS f2 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = int_a0)))" , eqProp "delete-scalar" deleteScalarX "DELETE FROM TEST.set_a \ \ WHERE (int_a0 = (SELECT ALL T0.int_b0 AS f0 \ \ FROM TEST.set_b T0 \ \ WHERE (T0.int_b0 = 0)))" ] tests :: [Test] tests = concat [ tables, monadic, directJoins, join3s, nested, bin, cases, uni , groups, orders, partitions, exps, effs, correlated] main :: IO () main = defaultMain tests relational-query-0.9.5.1/test/Model.hs0000644000000000000000000000261113206454105015722 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-} module Model where import GHC.Generics (Generic) import Data.Int (Int32, Int64) import Database.Relational.Query (defaultConfig) import Database.Relational.Query.TH (defineTable, makeRelationalRecordDefault, defineScalarDegree) $(defineTable defaultConfig "TEST" "set_a" [ ("int_a0" , [t| Int32 |]) , ("str_a1" , [t| String |]) , ("str_a2" , [t| String |]) ] [''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 |]) relational-query-0.9.5.1/test/sqlsEqArrow.hs0000644000000000000000000004663313206454105017161 0ustar0000000000000000{-# LANGUAGE Arrows #-} import Test.QuickCheck.Simple (Test, defaultMain) import qualified Test.QuickCheck.Simple as QSimple import Lex (eqProp, eqProp') import Model import Data.Int (Int32, Int64) import Control.Arrow (returnA, arr, (<<<), (***)) import Database.Relational.Query.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 = derivedUpdate $ proc _proj -> do assign intA0' -< value (0 :: Int32) returnA -< unitPlaceHolder registerX :: Insert (String, Maybe String) registerX = derivedInsertValue $ 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 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] -- Projection Operators bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection 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 :: (Projection Flat (Maybe Bool) -> Projection Flat (Maybe Bool) -> Projection 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 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO () _p_bin53 = print . bin53 bin :: [Test] bin = [ eqProp "equal" (bin53 (.=.)) "SELECT ALL (5 = 3) AS f0" , eqProp "lt" (bin53 (.<.)) "SELECT ALL (5 < 3) AS f0" , eqProp "le" (bin53 (.<=.)) "SELECT ALL (5 <= 3) AS f0" , eqProp "gt" (bin53 (.>.)) "SELECT ALL (5 > 3) AS f0" , eqProp "ge" (bin53 (.>=.)) "SELECT ALL (5 >= 3) AS f0" , eqProp "ne" (bin53 (.<>.)) "SELECT ALL (5 <> 3) AS f0" , eqProp "and" (boolTF and') "SELECT ALL ((0=0) AND (0=1)) AS f0" , eqProp "or" (boolTF or') "SELECT ALL ((0=0) OR (0=1)) AS f0" , eqProp "in" strIn "SELECT ALL ('foo' IN ('foo', 'bar')) AS f0" , eqProp "string concat" strConcat "SELECT ALL ('Hello, ' || 'World!') AS f0" , eqProp "like" strLike "SELECT ALL ('Hoge' LIKE 'H%') AS f0" , eqProp "plus" (bin53 (.+.)) "SELECT ALL (5 + 3) AS f0" , eqProp "minus" (bin53 (.-.)) "SELECT ALL (5 - 3) AS f0" , eqProp "mult" (bin53 (.*.)) "SELECT ALL (5 * 3) AS f0" , eqProp "div" (bin53 (./.)) "SELECT ALL (5 / 3) AS f0" ] 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 = derivedInsert id' insertI :: Insert SetI insertI = derivedInsert id' insertQueryX :: InsertQuery () insertQueryX = derivedInsertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = derivedUpdate $ proc proj -> do assign strA2' -< value "X" wheres -< proj ! strA1' .=. value "A" returnA -< unitPlaceHolder deleteX :: Delete () deleteX = derivedDelete $ proc proj -> do wheres -< proj ! strA1' .=. value "A" returnA -< unitPlaceHolder effs :: [Test] effs = [ eqProp "insert" insertX "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)" , eqProp "insert1" insertI "INSERT INTO TEST.set_i (int_i0) VALUES (?)" , eqProp "insertQuery" insertQueryX "INSERT INTO TEST.set_b (int_b0, str_b2, str_b2) SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" , eqProp "updateKey" updateKeyX "UPDATE TEST.set_a SET str_a1 = ?, str_a2 = ? WHERE int_a0 = ?" , eqProp "update" updateX "UPDATE TEST.set_a SET str_a2 = 'X' WHERE (str_a1 = 'A')" , eqProp "delete" deleteX "DELETE FROM TEST.set_a WHERE (str_a1 = 'A')" ] tests :: [Test] tests = concat [ tables, monadic, directJoins, join3s, nested, bin, maybes , groups, orders, partitions, exps, effs] main :: IO () main = defaultMain tests relational-query-0.9.5.1/test/Lex.hs0000644000000000000000000000776413206454105015430 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