diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,10 @@ -## 0.9.5.1 +## 0.10.0.0 -- add an upper bound of version constraint. +- switch namespace to Database.Relational +- update interfaces about projection types. +- divide and apply product-isomorphic interfaces. ## 0.9.5.0 diff --git a/relational-query.cabal b/relational-query.cabal --- a/relational-query.cabal +++ b/relational-query.cabal @@ -1,5 +1,5 @@ name: relational-query -version: 0.9.5.1 +version: 0.10.0.0 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can @@ -28,57 +28,64 @@ library exposed-modules: - Database.Relational.Query.Arrow + Database.Relational.Arrow + Database.Relational + Database.Relational.Table + Database.Relational.SimpleSql + Database.Relational.Pure + Database.Relational.Pi + Database.Relational.Pi.Unsafe + Database.Relational.Constraint + Database.Relational.Context + Database.Relational.Config + Database.Relational.SqlSyntax + Database.Relational.Record + Database.Relational.ProjectableClass + Database.Relational.Projectable + Database.Relational.ProjectableExtended + Database.Relational.TupleInstances + Database.Relational.Monad.BaseType + Database.Relational.Monad.Class + Database.Relational.Monad.Trans.Ordering + Database.Relational.Monad.Trans.Aggregating + Database.Relational.Monad.Trans.Restricting + Database.Relational.Monad.Trans.Join + Database.Relational.Monad.Trans.Config + Database.Relational.Monad.Trans.Assigning + Database.Relational.Monad.Type + Database.Relational.Monad.Simple + Database.Relational.Monad.Aggregate + Database.Relational.Monad.Unique + Database.Relational.Monad.Restrict + Database.Relational.Monad.Assign + Database.Relational.Monad.Register + Database.Relational.Relation + Database.Relational.Set + Database.Relational.Effect + Database.Relational.Scalar + Database.Relational.Type + Database.Relational.Derives + Database.Relational.BaseTH + Database.Relational.TH + + Database.Relational.Compat 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 + Database.Relational.Query.Arrow 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 + Database.Relational.Internal.ContextType + Database.Relational.Internal.Config + Database.Relational.Internal.String + Database.Relational.Internal.UntypedTable + Database.Relational.SqlSyntax.Types + Database.Relational.SqlSyntax.Join + Database.Relational.SqlSyntax.Aggregate + Database.Relational.SqlSyntax.Query + Database.Relational.SqlSyntax.Fold + Database.Relational.SqlSyntax.Updates + Database.Relational.Monad.Trans.JoinState + Database.Relational.Monad.Trans.Qualify build-depends: base <5 , array @@ -91,9 +98,10 @@ , dlist , template-haskell , th-reify-compat + , product-isomorphic >= 0.0.3 , sql-words >=0.1.5 , names-th - , persistable-record >= 0.5.1 && < 0.6 + , persistable-record >= 0.6 if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* @@ -105,6 +113,7 @@ test-suite sqls build-depends: base <5 , quickcheck-simple + , product-isomorphic , relational-query , containers , transformers @@ -125,6 +134,7 @@ test-suite sqlsArrow build-depends: base <5 , quickcheck-simple + , product-isomorphic , relational-query , containers , transformers diff --git a/src/Database/Relational.hs b/src/Database/Relational.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Database.Relational +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module is integrated module of Query. +module Database.Relational ( + module Database.Relational.Table, + module Database.Relational.SimpleSql, + module Database.Relational.Pi, + module Database.Relational.Constraint, + module Database.Relational.Context, + module Database.Relational.Config, + module Database.Relational.SqlSyntax, + module Database.Relational.Record, + module Database.Relational.ProjectableClass, + module Database.Relational.Projectable, + module Database.Relational.ProjectableExtended, + module Database.Relational.TupleInstances, + module Database.Relational.Monad.BaseType, + module Database.Relational.Monad.Class, + module Database.Relational.Monad.Trans.Ordering, + module Database.Relational.Monad.Trans.Aggregating, + module Database.Relational.Monad.Trans.Assigning, + module Database.Relational.Monad.Type, + module Database.Relational.Monad.Simple, + module Database.Relational.Monad.Aggregate, + module Database.Relational.Monad.Restrict, + module Database.Relational.Monad.Unique, + module Database.Relational.Monad.Assign, + module Database.Relational.Monad.Register, + module Database.Relational.Relation, + module Database.Relational.Set, + module Database.Relational.Scalar, + module Database.Relational.Type, + module Database.Relational.Effect, + module Database.Relational.Derives + ) where + +import Database.Relational.Table (Table, TableDerivable (..)) +import Database.Relational.SimpleSql (QuerySuffix, updateOtherThanKeySQL) +import Database.Relational.Pure () +import Database.Relational.Pi +import Database.Relational.Constraint + (Key, tableConstraint, projectionKey, + uniqueKey, -- notNullKey, + HasConstraintKey(constraintKey), + derivedUniqueKey, -- derivedNotNullKey, + Primary, Unique, NotNull) +import Database.Relational.Context +import Database.Relational.Config +import Database.Relational.SqlSyntax + (Order (..), Nulls (..), AggregateKey, Record, Predicate, PI, + SubQuery, unitSQL, queryWidth, ) +import Database.Relational.Record (RecordList, list) +import Database.Relational.ProjectableClass +import Database.Relational.Projectable +import Database.Relational.ProjectableExtended +import Database.Relational.TupleInstances +import Database.Relational.Monad.BaseType +import Database.Relational.Monad.Class + (MonadQualify, + MonadRestrict, wheres, having, restrict, + MonadAggregate, groupBy, groupBy', + MonadQuery, query', queryMaybe', + MonadPartition, partitionBy, + distinct, all', on) +import Database.Relational.Monad.Trans.Ordering (orderBy', orderBy, asc, desc) +import Database.Relational.Monad.Trans.Aggregating + (key, key', set, bkey, rollup, cube, groupingSets) +import Database.Relational.Monad.Trans.Assigning (assignTo, (<-#)) +import Database.Relational.Monad.Type +import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery) +import Database.Relational.Monad.Aggregate + (QueryAggregate, AggregatedQuery, Window, over) +import Database.Relational.Monad.Restrict (Restrict) +import Database.Relational.Monad.Unique (QueryUnique) +import Database.Relational.Monad.Assign (Assign) +import Database.Relational.Monad.Register (Register) +import Database.Relational.Relation +import Database.Relational.Set +import Database.Relational.Scalar (ScalarDegree) +import Database.Relational.Type hiding + (unsafeTypedKeyUpdate, unsafeTypedDelete, + unsafeTypedInsert, unsafeTypedInsertQuery, ) +import Database.Relational.Effect +import Database.Relational.Derives + +import Database.Record.Instances () + +{-# ANN module "HLint: ignore Use import/export shortcut" #-} diff --git a/src/Database/Relational/Arrow.hs b/src/Database/Relational/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Arrow.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.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 projected records may cause to break +-- the result query. +-- It is possible to controls injection of previous local projected records +-- by restricting domain type of arrow. This idea is imported from Opaleye: +-- +-- * +-- * +-- +-- Importing this module instead of "Database.Relational.Query" enables +-- to build query using arrow combinators. +module Database.Relational.Arrow ( + module Database.Relational, + + all', distinct, + + query, queryMaybe, query', queryMaybe', + queryList, queryList', queryExists, queryExists', queryListU, queryListU', + queryScalar, queryScalar', queryScalarU, queryScalarU', + + uniqueQuery', uniqueQueryMaybe', + + on, wheres, having, groupBy, placeholder, + + relation, relation', aggregateRelation, aggregateRelation', + + uniqueRelation', + + groupBy', key, key', set, bkey, rollup, cube, groupingSets, + + orderBy', orderBy, asc, desc, + + partitionBy, over, + + assign, + + 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 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 as Monadic +import qualified Database.Relational.Monad.Trans.Aggregating as Monadic +import qualified Database.Relational.Monad.Trans.Ordering as Monadic +import qualified Database.Relational.Monad.Trans.Assigning as Monadic + + +-- | Arrow to build queries. +newtype QueryA m a b = QueryA (Kleisli m a b) deriving (Category, Arrow) + +queryA :: (a -> m b) -> QueryA m a b +queryA = QueryA . Kleisli + +runQueryA :: QueryA m a b -> a -> m b +runQueryA (QueryA k) = runKleisli k + +runAofM :: (m b -> c) -> QueryA m () b -> c +runAofM = (. (`runQueryA` ())) + +-- | Arrow type corresponding to 'Monadic.QuerySimple' +type QuerySimple = QueryA Monadic.QuerySimple + +-- | Arrow type corresponding to 'Monadic.QueryAggregate' +type QueryAggregate = QueryA Monadic.QueryAggregate + +-- | Arrow type corresponding to 'Monadic.QueryUnique' +type QueryUnique = QueryA Monadic.QueryUnique + +-- | Arrow type corresponding to 'Monadic.AggregatingSet' +type AggregatingSet = QueryA Monadic.AggregatingSet + +-- | Arrow type corresponding to 'Monadic.AggregatingSetList' +type AggregatingSetList = QueryA Monadic.AggregatingSetList + +-- | Arrow type corresponding to 'Monadic.AggregatingPowerSet' +type AggregatingPowerSet = QueryA Monadic.AggregatingPowerSet + +-- | Arrow type corresponding to 'Monadic.Orderings' +type Orderings c m = QueryA (Monadic.Orderings c m) + +-- | Arrow type corresponding to 'Monadic.Window' +type Window c = QueryA (Monadic.Window c) + +-- | Arrow type corresponding to 'Monadic.Assignings' +type Assignings r m = QueryA (Monadic.Assignings r m) + +-- | Arrow type corresponding to 'Monadic.AssignStatement' +type AssignStatement r a = Assignings r Restrict (Record Flat r) a + +-- | Arrow type corresponding to 'Monadic.Register' +type Register r a = QueryA (Monadic.Register r) () a + +-- | Arrow type corresponding to 'Monadic.RestrictedStatement' +type RestrictedStatement r a = QueryA Monadic.Restrict (Record Flat r) a + + +-- | Same as 'Monadic.all''. Arrow version. +all' :: MonadQuery m => QueryA m () () +all' = queryA $ \() -> Monadic.all' + +-- | Same as 'Monadic.distinct'. Arrow version. +distinct :: MonadQuery m => QueryA m () () +distinct = queryA $ \() -> Monadic.distinct + +-- | Same as 'Monadic.query'. Arrow version. +-- The result arrow is not injected by local projected records. +query :: (MonadQualify ConfigureQuery m, MonadQuery m) + => Relation () r -> QueryA m () (Record Flat r) +query r = queryA $ \() -> Monadic.query r + +-- | Same as 'Monadic.queryMaybe'. Arrow version. +-- The result arrow is not injected by any local projected records. +queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) + => Relation () r -> QueryA m () (Record Flat (Maybe r)) +queryMaybe r = queryA $ \() -> Monadic.queryMaybe r + +-- | Same as 'Monadic.query''. Arrow version. +-- The result arrow is not injected by any local projected records. +query' :: (MonadQualify ConfigureQuery m, MonadQuery m) + => Relation p r -> QueryA m () (PlaceHolders p, Record Flat r) +query' r = queryA $ \() -> Monadic.query' r + +-- | Same as 'Monadic.queryMaybe''. Arrow version. +-- The result arrow is not injected by any local projected records. +queryMaybe' :: (MonadQualify ConfigureQuery m, MonadQuery m) + => Relation p r -> QueryA m () (PlaceHolders p, Record Flat (Maybe r)) +queryMaybe' r = queryA $ \() -> Monadic.queryMaybe' r + +unsafeQueryList :: MonadQualify ConfigureQuery m + => (a -> Relation () r) + -> QueryA m a (RecordList (Record c) r) +unsafeQueryList rf = queryA $ Monadic.queryList . rf + +unsafeQueryList' :: MonadQualify ConfigureQuery m + => (a -> Relation p r) + -> QueryA m a (PlaceHolders p, RecordList (Record c) r) +unsafeQueryList' rf = queryA $ Monadic.queryList' . rf + +-- | Same as 'Monadic.queryList'. Arrow version. +-- The result arrow is designed to be injected by local projected records. +queryList :: MonadQualify ConfigureQuery m + => (Record c a -> Relation () r) + -> QueryA m (Record c a) (RecordList (Record c) r) +queryList = unsafeQueryList + +-- | Same as 'Monadic.queryList''. Arrow version. +-- The result arrow is designed to be injected by local projected records. +queryList' :: MonadQualify ConfigureQuery m + => (Record c a -> Relation p r) + -> QueryA m (Record c a) (PlaceHolders p, RecordList (Record c) r) +queryList' = unsafeQueryList' + +-- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version. +-- The result arrow is designed to be injected by local projected records. +queryExists :: MonadQualify ConfigureQuery m + => (Record c a -> Relation () r) + -> QueryA m (Record c a) (RecordList (Record Exists) r) +queryExists = unsafeQueryList + +-- | Same as 'Monadic.queryList'' to pass this result to 'exists' operator. Arrow version. +-- The result arrow is designed to be injected by local projected records. +queryExists' :: MonadQualify ConfigureQuery m + => (Record c a -> Relation p r) + -> QueryA m (Record c a) (PlaceHolders p, RecordList (Record Exists) r) +queryExists' = unsafeQueryList' + +-- | Same as 'Monadic.queryList'. Arrow version. +-- Useful for no reference cases to local projected records. +queryListU :: MonadQualify ConfigureQuery m + => Relation () r + -> QueryA m () (RecordList (Record c) r) +queryListU r = unsafeQueryList $ \() -> r + +-- | Same as 'Monadic.queryList''. Arrow version. +-- Useful for no reference cases to local projected records. +queryListU' :: MonadQualify ConfigureQuery m + => Relation p r + -> QueryA m () (PlaceHolders p, RecordList (Record c) r) +queryListU' r = unsafeQueryList' $ \() -> r + +unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => (a -> UniqueRelation () c r) + -> QueryA m a (Record c (Maybe r)) +unsafeQueryScalar rf = queryA $ Monadic.queryScalar . rf + +unsafeQueryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => (a -> UniqueRelation p c r) + -> QueryA m a (PlaceHolders p, Record c (Maybe r)) +unsafeQueryScalar' rf = queryA $ Monadic.queryScalar' . rf + +-- | Same as 'Monadic.queryScalar'. Arrow version. +-- The result arrow is designed to be injected by any local projected record. +queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => (Record c a -> UniqueRelation () c r) + -> QueryA m (Record c a) (Record c (Maybe r)) +queryScalar = unsafeQueryScalar + +-- | Same as 'Monadic.queryScalar''. Arrow version. +-- The result arrow is designed to be injected by any local projected record. +queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => (Record c a -> UniqueRelation p c r) + -> QueryA m (Record c a) (PlaceHolders p, Record c (Maybe r)) +queryScalar' = unsafeQueryScalar' + +-- | Same as 'Monadic.queryScalar'. Arrow version. +-- Useful for no reference cases to local projected records. +queryScalarU :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => UniqueRelation () c r + -> QueryA m () (Record c (Maybe r)) +queryScalarU r = unsafeQueryScalar $ \() -> r + +-- | Same as 'Monadic.queryScalar''. Arrow version. +-- Useful for no reference cases to local projected records. +queryScalarU' :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => UniqueRelation p c r + -> QueryA m () (PlaceHolders p, Record c (Maybe r)) +queryScalarU' r = unsafeQueryScalar' $ \() -> r + +-- | Same as 'Monadic.uniqueQuery''. Arrow version. +-- The result arrow is not injected by local projected records. +uniqueQuery' :: UniqueRelation p c r + -> QueryA Monadic.QueryUnique () (PlaceHolders p, Record c r) +uniqueQuery' r = queryA $ \() -> Monadic.uniqueQuery' r + +-- | Same as 'Monadic.uniqueQueryMaybe''. Arrow version. +-- The result arrow is not injected by local projected records. +uniqueQueryMaybe' :: UniqueRelation p c r + -> QueryA Monadic.QueryUnique () (PlaceHolders p, Record c (Maybe r)) +uniqueQueryMaybe' r = queryA $ \() -> Monadic.uniqueQueryMaybe' r + +-- | Same as 'Monadic.on'. Arrow version. +-- The result arrow is designed to be injected by local conditional flat-records. +on :: MonadQuery m + => QueryA m (Predicate Flat) () +on = queryA Monadic.on + +-- | Same as 'Monadic.wheres'. Arrow version. +-- The result arrow is designed to be injected by local conditional flat-records. +wheres :: MonadRestrict Flat m + => QueryA m (Predicate Flat) () +wheres = queryA Monadic.wheres + +-- | Same as 'Monadic.having'. Arrow version. +-- The result arrow is designed to be injected by local conditional aggregated-records. +having :: MonadRestrict Aggregated m + => QueryA m (Predicate Aggregated) () +having = queryA Monadic.having + +-- | Same as 'Monadic.groupBy'. Arrow version. +-- The result arrow is designed to be injected by local flat-records. +groupBy :: MonadAggregate m + => QueryA m (Record Flat r) (Record Aggregated r) +groupBy = queryA Monadic.groupBy + +-- | Same as 'Monadic.placeholder'. Arrow version. +-- The result arrow is designed to be injected by locally built arrow using placeholders. +placeholder :: (PersistableWidth t, SqlContext c, Monad m) + => QueryA m (QueryA m (Record c t) a) (PlaceHolders t, a) +placeholder = queryA $ Monadic.placeholder . runQueryA + +-- | Same as 'Monadic.relation'. +-- Finalize query-building arrow instead of query-building monad. +relation :: QuerySimple () (Record Flat r) + -> Relation () r +relation = runAofM Monadic.relation + +-- | Same as 'Monadic.relation''. +-- Finalize query-building arrow instead of query-building monad. +relation' :: QuerySimple () (PlaceHolders p, Record Flat r) + -> Relation p r +relation' = runAofM Monadic.relation' + +-- | Same as 'Monadic.aggregateRelation'. +-- Finalize query-building arrow instead of query-building monad. +aggregateRelation :: QueryAggregate () (Record Aggregated r) + -> Relation () r +aggregateRelation = runAofM Monadic.aggregateRelation + +-- | Same as 'Monadic.aggregateRelation''. +-- Finalize query-building arrow instead of query-building monad. +aggregateRelation' :: QueryAggregate () (PlaceHolders p, Record Aggregated r) + -> Relation p r +aggregateRelation' = runAofM Monadic.aggregateRelation' + +-- | Same as 'Monadic.uniqueRelation''. +-- Finalize query-building arrow instead of query-building monad. +uniqueRelation' :: QueryUnique () (PlaceHolders p, Record c r) + -> UniqueRelation p c r +uniqueRelation' = runAofM Monadic.uniqueRelation' + +-- | Same as 'Monadic.groupBy''. +-- This arrow is designed to be injected by local 'AggregateKey'. +groupBy' :: MonadAggregate m => QueryA m (AggregateKey (Record Aggregated r)) (Record Aggregated r) +groupBy' = queryA Monadic.groupBy' + +-- | Same as 'Monadic.key'. +-- This arrow is designed to be injected by local flat-records. +key :: AggregatingSet (Record Flat r) (Record Aggregated (Maybe r)) +key = queryA Monadic.key + +-- | Same as 'Monadic.key''. +-- This arrow is designed to be injected by local 'AggregteKey'. +key' :: AggregatingSet (AggregateKey a) a +key' = queryA Monadic.key' + +-- | Same as 'Monadic.set'. +-- This arrow is designed to be injected by locally built 'AggregtingSet' arrow. +set :: AggregatingSetList (AggregatingSet () a) a +set = queryA $ runAofM Monadic.set + +-- | Same as 'Monadic.bkey'. +-- This arrow is designed to be injected by local flat-records. +bkey :: AggregatingPowerSet (Record Flat r) (Record Aggregated (Maybe r)) +bkey = queryA Monadic.bkey + +-- | Same as 'Monadic.rollup'. +-- Finalize locally built 'AggregatingPowerSet'. +rollup :: AggregatingPowerSet () a -> AggregateKey a +rollup = runAofM Monadic.rollup + +-- | Same as 'Monadic.cube'. +-- Finalize locally built 'AggregatingPowerSet'. +cube :: AggregatingPowerSet () a -> AggregateKey a +cube = runAofM Monadic.cube + +-- | Same as 'Monadic.groupingSets'. +-- Finalize locally built 'AggregatingSetList'. +groupingSets :: AggregatingSetList () a -> AggregateKey a +groupingSets = runAofM Monadic.groupingSets + +-- | Same as 'Monadic.orderBy''. +-- The result arrow is designed to be injected by local projected records. +orderBy' :: Monad m + => Order + -> Nulls + -> Orderings c m (Record c t) () +orderBy' o n = queryA $ \p -> Monadic.orderBy' p o n + +-- | Same as 'Monadic.orderBy'. +-- The result arrow is designed to be injected by local projected records. +orderBy :: Monad m + => Order + -> Orderings c m (Record c t) () +orderBy o = queryA (`Monadic.orderBy` o) + +-- | Same as 'Monadic.asc'. +-- The result arrow is designed to be injected by local projected records. +asc :: Monad m + => Orderings c m (Record c t) () +asc = queryA Monadic.asc + +-- | Same as 'Monadic.desc'. +-- The result arrow is designed to be injected by local projected records. +desc :: Monad m + => Orderings c m (Record c t) () +desc = queryA Monadic.desc + +-- | Same as 'Monadic.partitionBy'. +-- The result arrow is designed to be injected by local projected records. +partitionBy :: Window c (Record c r) () +partitionBy = queryA Monadic.partitionBy + +-- | Same as 'Monadic.over'. +-- Make record of window function result using built 'Window' arrow. +over :: SqlContext c + => Record OverWindow a -> Window c () () -> Record c a +over po = runAofM $ Monadic.over po + +infix 8 `over` + +-- | Make 'Monadic.AssignTarget' into arrow which is designed to be +-- injected by assignees of local projected record. +assign :: Monad m + => Monadic.AssignTarget r v + -> Assignings r m (Record Flat v) () +assign t = queryA (`Monadic.assignTo` t) + +-- | Same as 'Monadic.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 diff --git a/src/Database/Relational/BaseTH.hs b/src/Database/Relational/BaseTH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/BaseTH.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Module : Database.Relational.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.BaseTH ( + defineTupleShowConstantInstance, + defineTuplePi, + + defineRecordProjections, + ) where + +import Control.Applicative ((<$>)) +import Data.List (foldl', inits) +import Language.Haskell.TH + (Q, Name, mkName, normalB, classP, varP, + TypeQ, forallT, varT, tupleT, appT, + Dec, sigD, valD, instanceD, + TyVarBndr (PlainTV), ) +import Database.Record.Persistable + (PersistableWidth, persistableWidth, + PersistableRecordWidth, runPersistableRecordWidth) + +import Database.Relational.ProjectableClass (ShowConstantTermsSQL (..)) +import Database.Relational.Pi.Unsafe (Pi, definePi) + + +tupleN :: Int -> (([Name], [TypeQ]), TypeQ) +tupleN n = ((ns, vs), foldl' appT (tupleT n) vs) + where + ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ] + vs = map varT ns + +-- | Make template of '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 |] + [] + +-- | Make polymorphic projection templates. +defineRecordProjections :: TypeQ -> [Name] -> [Name] -> [TypeQ] -> Q [Dec] +defineRecordProjections tyRec avs sels cts = + fmap concat . sequence $ zipWith3 template cts (inits cts) sels + where + template :: TypeQ -> [TypeQ] -> Name -> Q [Dec] + template ct pcts selN = do + sig <- sigD selN $ + forallT (map PlainTV avs) + (mapM (classP ''PersistableWidth . (:[]) . varT) avs) + [t| Pi $tyRec $ct |] + let runPW t = [| runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |] + val <- valD (varP selN) + (normalB [| definePi $(foldl' (\e t -> [| $e + $(runPW t) |]) [| 0 :: Int |] pcts) |]) [] + return [sig, val] + +-- | Make templates of projection paths for tuple types. +defineTuplePi :: Int -> Q [Dec] +defineTuplePi n = + defineRecordProjections tyRec avs sels cts + where + ((avs, cts), tyRec) = tupleN n + sels = [ mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'" + | i <- [ 0 .. n - 1] ] diff --git a/src/Database/Relational/Compat.hs b/src/Database/Relational/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Compat.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} + +-- | +-- Module : Database.Relational.Compat +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains backward compatibility definitions of +-- relational-query <= 0.9.* +module Database.Relational.Compat + {-# DEPRECATED "backward compatibility definitions relational-query <= 0.9.*" #-} ( + -- * deprecated types + Projection, ListProjection, + + -- * deprecated classes + ProductConstructor (..), + ProjectableFunctor, (|$|), ProjectableApplicative, (|*|), + + ProjectableIdZip, rightId, leftId, + + SqlProjectable (..), unsafeProjectSql, + ProjectableShowSql (..), unsafeShowSql, + + -- * deprecated defintions about Pi + pfmap, pap, pzero, + ) where + +import Data.Functor.ProductIsomorphic + (ProductIsoFunctor, (|$|), ProductIsoApplicative, (|*|), + ProductIsoEmpty, pureE, peRight, peLeft, ) +import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..)) + +import Database.Relational hiding (unsafeShowSql', unsafeShowSql, unsafeProjectSqlTerms, unsafeProjectSql, ) +import Database.Relational.Internal.String (showStringSQL, stringSQL) +import qualified Database.Relational.Record as Record +import qualified Database.Relational.Projectable as Projectable + +{-# DEPRECATED Projection "Replaced by Record type" #-} +-- | deprecated 'Projection' type replaced by 'Record' type. +type Projection = Record + +{-# DEPRECATED ListProjection "Replaced by RecordList type" #-} +-- | deprecated 'Projection' type replaced by 'Record' type. +type ListProjection = RecordList + +{-# DEPRECATED ProjectableFunctor "use ProductIsoFunctor in Data.Functor.ProductIsomorphic instead of this. " #-} +-- | deprecated 'ProjectableFunctor' class replaced by 'ProductIsoFunctor' class. +type ProjectableFunctor = ProductIsoFunctor + +{-# DEPRECATED ProjectableApplicative "use ProductIsoApplicative in Data.Functor.ProductIsomorphic instead of this. " #-} +-- | deprecated 'ProjectableApplicative' class replaced by 'ProductIsoApplicative' class. +type ProjectableApplicative = ProductIsoApplicative + +{-# DEPRECATED ProjectableIdZip "use ProductIsoEmpty in Data.Functor.ProductIsomorphic instead of this. " #-} +-- | deprecated 'ProjectableIdZip' class replaced by 'ProductIsoEmpty' class. +type ProjectableIdZip p = ProductIsoEmpty p () + +{-# DEPRECATED rightId "use peRight in Data.Functor.ProductIsomorphic instead of this. " #-} +-- | deprecated right-id-law definition replaced by 'peRight' +rightId :: ProjectableIdZip p => p (a, ()) -> p a +rightId = peRight + +{-# DEPRECATED leftId "use peLeft in Data.Functor.ProductIsomorphic instead of this. " #-} +-- | deprecated left-id-law definition replaced by 'peLeft' +leftId :: ProjectableIdZip p => p ((), a) -> p a +leftId = peLeft + +-- Pi + +{-# DEPRECATED pfmap "use (|$|) in Data.Functor.ProductIsomorphic instead of this." #-} +-- | deprecated map definition for Pi type. use ('|$|') instead of this. +pfmap :: ProductConstructor (a -> b) => (a -> b) -> Pi r a -> Pi r b +pfmap = (|$|) + +{-# DEPRECATED pap "use (|*|) in Data.Functor.ProductIsomorphic instead of this." #-} +-- | deprecated ap definition for Pi type. use ('|*|') instead of this. +pap :: Pi r (a -> b) -> Pi r a -> Pi r b +pap = (|*|) + +{-# DEPRECATED pzero "use pureE in Data.Functor.ProductIsomorphic instead of this." #-} +-- | deprecated empty definition for Pi type. use 'pureE' instead of this. +pzero :: Pi a () +pzero = pureE + +-- type classes + +{-# DEPRECATED SqlProjectable "use 'SqlContext c => Record c a' instead of 'SqlProjectable p => p a'." #-} +-- | Interface to project SQL terms unsafely. +class SqlProjectable p where + -- | Unsafely project from SQL expression terms. + unsafeProjectSqlTerms :: [StringSQL] -- ^ SQL expression strings + -> p t -- ^ Result record +{-# DEPRECATED unsafeProjectSqlTerms "Use Database.Relational.unsafeProjectSqlTerms instead of this." #-} + +-- | Unsafely make 'Record' from SQL terms. +instance SqlContext c => SqlProjectable (Record c) where + unsafeProjectSqlTerms = Projectable.unsafeProjectSqlTerms + +{-# DEPRECATED unsafeProjectSql "Use Database.Relational.unsafeProjectSql instead of this." #-} +unsafeProjectSql :: SqlProjectable p => String -> p a +unsafeProjectSql = unsafeProjectSqlTerms . (:[]) . stringSQL + +{-# DEPRECATED ProjectableShowSql "specialized type 'Record c' should be used instead of this constraint." #-} +-- | Interface to get SQL expression from a record. +class ProjectableShowSql p where + unsafeShowSql' :: p a -> StringSQL +{-# DEPRECATED unsafeShowSql' "Use Database.Relational.unsafeShowSql' instead of this." #-} + +instance ProjectableShowSql (Record c) where + unsafeShowSql' = Record.unsafeStringSql + +{-# DEPRECATED unsafeShowSql "Use Database.Relational.unsafeShowSql instead of this." #-} +unsafeShowSql :: ProjectableShowSql p => p a -> String +unsafeShowSql = showStringSQL . unsafeShowSql' diff --git a/src/Database/Relational/Config.hs b/src/Database/Relational/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Config.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Database.Relational.Config +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides untyped components for query. +module Database.Relational.Config + ( -- * Configuration type for query + module Database.Relational.Internal.Config, + ) where + +import Database.Relational.Internal.Config + (NameConfig (..), + ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), + Config (..), defaultConfig,) diff --git a/src/Database/Relational/Constraint.hs b/src/Database/Relational/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Constraint.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Constraint +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides proof object definitions of constraint key. +-- Difference between this module and "Database.Record.KeyConstraint" is +-- typed constraint key column definition is included in this module. +module Database.Relational.Constraint ( + -- * Constraint Key proof object + Key, indexes, unsafeDefineConstraintKey, + tableConstraint, projectionKey, + + -- unsafeReturnKey, -- unsafeAppendConstraint, + + -- * Derivation rules + uniqueKey, -- notNullKey, + + -- * Inference rules + HasConstraintKey (..), + derivedUniqueKey, -- derivedNotNullKey, + + -- * Constraint types + Primary, Unique, NotNull + ) where + + +import Database.Record (PersistableRecordWidth, PersistableWidth (persistableWidth)) +import Database.Record.KeyConstraint + (KeyConstraint, unsafeSpecifyKeyConstraint, + Primary, Unique, NotNull) +import qualified Database.Record.KeyConstraint as C + +import Database.Relational.Pi (Pi) +import qualified Database.Relational.Pi.Unsafe as UnsafePi + + +-- | Constraint Key proof object. Constraint type 'c', record type 'r' and columns type 'ct'. +data Key c r ct = Key [Int] (PersistableRecordWidth ct) + +-- | Index of key which specifies constraint key. +indexes :: Key c r ct -> [Int] +indexes (Key is _) = is + +-- | Width of key. +width :: Key c r ct -> PersistableRecordWidth ct +width (Key _ w) = w + +-- | Unsafely generate constraint 'Key' proof object using specified key index. +unsafeDefineConstraintKey :: PersistableWidth ct + => [Int] -- ^ Key indexes which specify this constraint key + -> Key c r ct -- ^ Result constraint key proof object +unsafeDefineConstraintKey ixs = Key ixs persistableWidth + +-- | Get table constraint 'KeyConstraint' proof object from constraint 'Key'. +tableConstraint :: Key c r ct -> KeyConstraint c r +tableConstraint = unsafeSpecifyKeyConstraint . indexes + +-- | Get projection path proof object from constraint 'Key'. +projectionKey :: Key c r ct -> Pi r ct +projectionKey k = UnsafePi.defineDirectPi' w ixs where + ixs = indexes k + w = width k + +-- | Unsafe. Make constraint key to add column phantom type +unsafeReturnKey :: PersistableWidth ct + => KeyConstraint c r -> Key c r ct +unsafeReturnKey = unsafeDefineConstraintKey . C.indexes + +-- -- | Unsafe. Make constraint key to add constraint phantom type +-- unsafeAppendConstraint :: Pi r ct -> Key c r ct +-- unsafeAppendConstraint = unsafeDefineConstraintKey . leafIndex + + +-- | Map from table constraint into constraint 'Key'. +mapConstraint :: PersistableWidth ct + => (KeyConstraint c0 r -> KeyConstraint c1 r) + -> Key c0 r ct + -> Key c1 r ct +mapConstraint f = unsafeReturnKey . f . tableConstraint + +-- | Derive 'Unique' constraint 'Key' from 'Primary' constraint 'Key' +uniqueKey :: PersistableWidth ct + => Key Primary r ct -> Key Unique r ct +uniqueKey = mapConstraint C.unique + +-- -- | Derive 'NotNull' constraint 'Key' from 'Primary' constraint 'Key' +-- notNullKey :: Key Primary r ct -> Key NotNull r ct +-- notNullKey = mapConstraint C.notNull + + +-- | Constraint 'Key' inference interface. +class PersistableWidth ct => HasConstraintKey c r ct where + -- | Infer constraint key. + constraintKey :: Key c r ct + +-- | Inferred 'Unique' constraint 'Key'. +-- Record type 'r' has unique key which type is 'ct' derived from primay key. +derivedUniqueKey :: HasConstraintKey Primary r ct => Key Unique r ct +derivedUniqueKey = uniqueKey constraintKey + +-- -- | Inferred 'NotNull' constraint 'Key'. +-- -- Record type 'r' has not-null key which type is 'ct' derived from primay key. +-- derivedNotNullKey :: HasConstraintKey Primary r ct => Key NotNull r ct +-- derivedNotNullKey = notNullKey constraintKey diff --git a/src/Database/Relational/Context.hs b/src/Database/Relational/Context.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Context.hs @@ -0,0 +1,15 @@ +-- | +-- Module : Database.Relational.Context +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module re-export query context tag types. +module Database.Relational.Context + ( module Database.Relational.Internal.ContextType + ) where + +import Database.Relational.Internal.ContextType diff --git a/src/Database/Relational/Derives.hs b/src/Database/Relational/Derives.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Derives.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Derives +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines typed SQLs derived from type informations. +module Database.Relational.Derives ( + -- * Query derivation + specifiedKey, + + unique, + + primary', primary, + + -- * Update derivation + updateByConstraintKey, + primaryUpdate, + + updateValuesWithKey, + + -- * Derived objects from table + derivedUniqueRelation + ) where + +import Database.Record (PersistableWidth, ToSql) +import Database.Record.ToSql (unsafeUpdateValuesWithIndexes) + +import Database.Relational.SqlSyntax (Record) + +import Database.Relational.Table (Table, TableDerivable) +import Database.Relational.Pi.Unsafe (Pi, unsafeExpandIndexes) +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable (placeholder, (.=.)) +import Database.Relational.ProjectableExtended ((!)) +import Database.Relational.Monad.Class (wheres) +import Database.Relational.Monad.BaseType (Relation, relationWidth) +import Database.Relational.Relation + (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique) +import Database.Relational.Constraint + (Key, Primary, Unique, projectionKey, uniqueKey, + HasConstraintKey(constraintKey)) +import qualified Database.Relational.Constraint as Constraint +import Database.Relational.Type (KeyUpdate, typedKeyUpdate) + + +-- | Query restricted with specified key. +specifiedKey :: PersistableWidth p + => Pi a p -- ^ 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 $ Record.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 . 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'. + -> Record c k -- ^ Unique key value to specify. + -> UniqueRelation () c r -- ^ Result restricted 'Relation' +derivedUniqueRelation uk kp = unsafeUnique . relation $ do + r <- query derivedRelation + wheres $ r ! projectionKey uk .=. Record.unsafeChangeContext kp + return r diff --git a/src/Database/Relational/Effect.hs b/src/Database/Relational/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Effect.hs @@ -0,0 +1,185 @@ +-- | +-- Module : Database.Relational.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.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 Data.Functor.ProductIsomorphic (peRight) + +import Language.SQL.Keyword (Keyword(..)) +import Database.Record.Persistable (PersistableWidth) + +import Database.Relational.Internal.Config (Config (chunksInsertSize), defaultConfig) +import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) +import Database.Relational.SqlSyntax + (composeWhere, composeSets, composeChunkValuesWithColumns) + +import Database.Relational.Pi (Pi, id') +import qualified Database.Relational.Pi.Unsafe as Pi +import Database.Relational.Table (Table, TableDerivable, derivedTable) +import qualified Database.Relational.Table as Table +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable + (PlaceHolders, unitPlaceHolder, + pwPlaceholder, placeholder, (><), ) +import Database.Relational.Monad.Trans.Assigning (assignings, (<-#)) +import Database.Relational.Monad.Restrict (RestrictedStatement) +import qualified Database.Relational.Monad.Restrict as Restrict +import Database.Relational.Monad.Assign (AssignStatement) +import qualified Database.Relational.Monad.Assign as Assign +import Database.Relational.Monad.Register (Register) +import qualified Database.Relational.Monad.Register as Register + + +-- | Restriction type with place-holder parameter 'p' and projected 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) = 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 $ Record.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 projected 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 + +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 peRight $ 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 (Record.unsafeFromTable tbl)) config + +instance TableDerivable r => Show (UpdateTarget p r) where + show = showStringSQL . sqlFromUpdateTarget defaultConfig derivedTable + + +-- | InsertTarget type with place-holder parameter 'p' and projected record type 'r'. +newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p)) + +-- | Finalize 'Register' monad and generate 'InsertTarget'. +insertTarget :: Register r () + -> InsertTarget () r +insertTarget = InsertTarget . (>> return 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 diff --git a/src/Database/Relational/Internal/Config.hs b/src/Database/Relational/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Internal/Config.hs @@ -0,0 +1,74 @@ +-- | +-- Module : Database.Relational.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.Internal.Config ( + NameConfig (..), + ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), + Config ( productUnitSupport + , chunksInsertSize + , schemaNameMode + , normalizedTableName + , verboseAsCompilerWarning + , identifierQuotation + , nameConfig), + defaultConfig, + ) where + +import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) +import qualified Database.Record.TH as RecordTH + + +-- | 'NameConfig' type to customize names of expanded templates. +data NameConfig = + NameConfig + { recordConfig :: RecordTH.NameConfig + , relationVarName :: String -> String -> VarName + } + +instance Show NameConfig where + show = const "" + +-- | Unit of product is supported or not. +data ProductUnitSupport = PUSupported | PUNotSupported deriving Show + +-- | Schema name qualify mode in SQL string. +data SchemaNameMode + = SchemaQualified -- ^ Schema qualified table name in SQL string + | SchemaNotQualified -- ^ Not qualified table name in SQL string + deriving (Eq, Show) + +-- | Configuration for quotation of identifiers of SQL. +data IdentifierQuotation = NoQuotation | Quotation Char deriving Show + +-- | Configuration type. +data Config = + Config + { productUnitSupport :: !ProductUnitSupport + , chunksInsertSize :: !Int + , schemaNameMode :: !SchemaNameMode + , normalizedTableName :: !Bool + , verboseAsCompilerWarning :: !Bool + , identifierQuotation :: !IdentifierQuotation + , nameConfig :: !NameConfig + } deriving Show + +-- | Default configuration. +defaultConfig :: Config +defaultConfig = + Config { productUnitSupport = PUSupported + , chunksInsertSize = 256 + , schemaNameMode = SchemaQualified + , normalizedTableName = True + , verboseAsCompilerWarning = False + , identifierQuotation = NoQuotation + , nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig + , relationVarName = const varCamelcaseName + } + } diff --git a/src/Database/Relational/Internal/ContextType.hs b/src/Database/Relational/Internal/ContextType.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Internal/ContextType.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- | +-- Module : Database.Relational.Internal.ContextType +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines query context tag types. +module Database.Relational.Internal.ContextType ( + Flat, Aggregated, Exists, OverWindow, + + Set, SetList, Power, + ) where + +-- | Type tag for flat (not-aggregated) query +data Flat + +-- | Type tag for aggregated query +data Aggregated + +-- | Type tag for exists predicate +data Exists + +-- | Type tag for window function building +data OverWindow + + +-- | Type tag for normal aggregatings set +data Set + +-- | Type tag for aggregatings GROUPING SETS +data SetList + +-- | Type tag for aggregatings power set +data Power diff --git a/src/Database/Relational/Internal/String.hs b/src/Database/Relational/Internal/String.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Internal/String.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.Internal.String +-- 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.Internal.String ( + StringSQL, stringSQL, showStringSQL, + + rowStringSQL, rowPlaceHolderStringSQL, + + rowConsStringSQL, listStringSQL, + + boolSQL, + ) where + +import Language.SQL.Keyword (Keyword, word, wordShow, fold, (|*|), paren) + + +-- | String wrap type for SQL strings. +type StringSQL = Keyword + +-- | 'StringSQL' from 'String'. +stringSQL :: String -> StringSQL +stringSQL = word + +-- | 'StringSQL' to 'String'. +showStringSQL :: StringSQL -> String +showStringSQL = wordShow + +-- | Row String of SQL values. +rowStringSQL :: [StringSQL] -> StringSQL +rowStringSQL = d where + d [] = error "Record: no columns. empty row is not allowed in SQL." + d [c] = c + d cs = paren $ fold (|*|) cs + +-- | Place holder row String of SQL. +rowPlaceHolderStringSQL :: Int -> StringSQL +rowPlaceHolderStringSQL = rowStringSQL . (`replicate` stringSQL "?") + +-- | List String of SQL. +rowConsStringSQL :: [StringSQL] -> StringSQL +rowConsStringSQL = paren . fold (|*|) + +-- | List String of SQL. +listStringSQL :: [StringSQL] -> StringSQL +listStringSQL = paren . fold (|*|) + +-- | SQL expressions for Bool type. +boolSQL :: Bool -> StringSQL +boolSQL = + stringSQL . d + where + d True = "(0=0)" + d False = "(0=1)" diff --git a/src/Database/Relational/Internal/UntypedTable.hs b/src/Database/Relational/Internal/UntypedTable.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Internal/UntypedTable.hs @@ -0,0 +1,44 @@ +-- | +-- Module : Database.Relational.Internal.UntypedTable +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines no-phantom table type which has table metadatas. +module Database.Relational.Internal.UntypedTable ( + Untyped (Untyped), name', width', columns', (!), + ) where + +import Data.Array (Array, elems) +import qualified Data.Array as Array + +import Database.Relational.Internal.String (StringSQL) + + +-- | Untyped typed table type +data Untyped = Untyped String Int (Array Int StringSQL) deriving Show + +-- | Name string of table in SQL +name' :: Untyped -> String +name' (Untyped n _ _) = n + +-- | Width of table +width' :: Untyped -> Int +width' (Untyped _ w _) = w + +-- | Column name strings in SQL +columnArray :: Untyped -> Array Int StringSQL +columnArray (Untyped _ _ c) = c + +-- | Column name strings in SQL +columns' :: Untyped -> [StringSQL] +columns' = elems . columnArray + +-- | Column name string in SQL specified by index +(!) :: Untyped + -> Int -- ^ Column index + -> StringSQL -- ^ Column name String in SQL +t ! i = columnArray t Array.! i diff --git a/src/Database/Relational/Monad/Aggregate.hs b/src/Database/Relational/Monad/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Aggregate.hs @@ -0,0 +1,103 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Monad.Aggregate +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about aggregated query type. +module Database.Relational.Monad.Aggregate ( + -- * Aggregated Query + QueryAggregate, + AggregatedQuery, + + toSQL, + + toSubQuery, + + Window, over + ) where + +import Data.Functor.Identity (Identity (runIdentity)) +import Data.Monoid ((<>)) + +import Language.SQL.Keyword (Keyword(..)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow) +import Database.Relational.SqlSyntax + (Duplication, Record, SubQuery, Predicate, JoinProduct, + OrderingTerm, composeOrderBy, aggregatedSubQuery, + AggregateColumnRef, AggregateElem, composePartitionBy, ) +import qualified Database.Relational.SqlSyntax as Syntax + +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable (PlaceHolders, SqlContext) +import Database.Relational.Monad.Class (MonadRestrict(..)) +import Database.Relational.Monad.Trans.Restricting + (Restrictings, restrictings, extractRestrict) +import Database.Relational.Monad.Trans.Aggregating + (extractAggregateTerms, AggregatingSetT, PartitioningSet) +import Database.Relational.Monad.Trans.Ordering + (Orderings, extractOrderingTerms) +import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig) +import Database.Relational.Monad.Type (QueryCore, extractCore, OrderedQuery) + + +-- | Aggregated query monad type. +type QueryAggregate = Orderings Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) + +-- | Aggregated query type. 'AggregatedQuery' p r == 'QueryAggregate' ('PlaceHolders' p, 'Record' 'Aggregated' r). +type AggregatedQuery p r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) p r + +-- | Partition monad type for partition-by clause. +type Window c = Orderings c (PartitioningSet c) + +-- | Restricted 'MonadRestrict' instance. +instance MonadRestrict Flat q => MonadRestrict Flat (Restrictings Aggregated q) where + restrict = restrictings . restrict + +extract :: AggregatedQuery p r + -> ConfigureQuery (((((((PlaceHolders p, Record Aggregated r), [OrderingTerm]), + [Predicate Aggregated]), + [AggregateElem]), + [Predicate Flat]), + JoinProduct), Duplication) +extract = extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms + +-- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation. +toSQL :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run + -> ConfigureQuery String -- ^ Result SQL string with 'ConfigureQuery' computation +toSQL = fmap Syntax.toSQL . toSubQuery + +-- | Run 'AggregatedQuery' to get 'SubQuery' with 'ConfigureQuery' computation. +toSubQuery :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation +toSubQuery q = do + (((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q + c <- askConfig + return $ aggregatedSubQuery c (Record.untype pj) da pd rs ag grs ot + +extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef]) +extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms + +-- | Operator to make record of window function result using built 'Window' monad. +over :: SqlContext c + => Record OverWindow a + -> Window c () + -> Record c a +wp `over` win = + Record.unsafeFromSqlTerms + [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot) + | c <- Record.columns wp + ] where (((), ot), pt) = extractWindow win + +infix 8 `over` diff --git a/src/Database/Relational/Monad/Assign.hs b/src/Database/Relational/Monad/Assign.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Assign.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Monad.Assign ( + -- * Monad to restrict target records with assignment. + Assign, AssignStatement, + -- updateStatement, + extract, + ) where + +import Database.Relational.Internal.Config (Config) +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax + (Predicate, Record, Assignment) + +import Database.Relational.Table (Table) +import Database.Relational.Monad.Restrict (Restrict) +import qualified Database.Relational.Monad.Restrict as Restrict +import Database.Relational.Monad.Trans.Assigning (Assignings, extractAssignments) + + +-- | Target update monad type used from update statement and merge statement. +type Assign r = Assignings r Restrict + +-- | AssignStatement type synonym. +-- Specifying assignments and restrictions like update statement. +-- Record type must be +-- the same as 'Target' type parameter 'r'. +type AssignStatement r a = Record Flat r -> Assign r a + +-- -- | '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]), [Predicate Flat]) +extract = Restrict.extract . extractAssignments diff --git a/src/Database/Relational/Monad/BaseType.hs b/src/Database/Relational/Monad/BaseType.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/BaseType.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Database.Relational.Monad.BaseType +-- Copyright : 2015-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines base monad type to build queries. +module Database.Relational.Monad.BaseType + ( -- * Base monad type to build queries + ConfigureQuery, configureQuery, + qualifyQuery, askConfig, + + -- * Relation type + Relation, unsafeTypeRelation, untypeRelation, relationWidth, + + dump, + sqlFromRelationWith, sqlFromRelation, + + rightPh, leftPh, + ) where + +import Data.Functor.Identity (Identity, runIdentity) +import Control.Applicative ((<$>)) + +import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth) + +import Database.Relational.Internal.String (StringSQL, showStringSQL) +import Database.Relational.Internal.Config (Config, defaultConfig) +import Database.Relational.SqlSyntax (Qualified, SubQuery, showSQL, width) + +import qualified Database.Relational.Monad.Trans.Qualify as Qualify +import Database.Relational.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) +import Database.Relational.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig) + +-- | Thin monad type for untyped structure. +type ConfigureQuery = Qualify (QueryConfig Identity) + +-- | Run 'ConfigureQuery' monad with initial state to get only result. +configureQuery :: ConfigureQuery q -> Config -> q +configureQuery cq c = runIdentity $ runQueryConfig (evalQualifyPrime cq) c + +-- | Get qualifyed table form query. +qualifyQuery :: a -> ConfigureQuery (Qualified a) +qualifyQuery = Qualify.qualifyQuery + +-- | Read configuration. +askConfig :: ConfigureQuery Config +askConfig = qualify askQueryConfig + + +-- | Relation type with place-holder parameter 'p' and query result type 'r'. +newtype Relation p r = SubQuery (ConfigureQuery SubQuery) + +-- | Unsafely type qualified subquery into record typed relation type. +unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r +unsafeTypeRelation = SubQuery + +-- | Sub-query Qualify monad from relation. +untypeRelation :: Relation p r -> ConfigureQuery SubQuery +untypeRelation (SubQuery qsub) = qsub + +-- | 'PersistableRecordWidth' of 'Relation' type. +relationWidth :: Relation p r -> PersistableRecordWidth r +relationWidth rel = + unsafePersistableRecordWidth . width $ configureQuery (untypeRelation rel) defaultConfig + --- Assume that width is independent from Config structure + +unsafeCastPlaceHolder :: Relation a r -> Relation b r +unsafeCastPlaceHolder (SubQuery qsub) = SubQuery qsub + +-- | Simplify placeholder type applying left identity element. +rightPh :: Relation ((), p) r -> Relation p r +rightPh = unsafeCastPlaceHolder + +-- | Simplify placeholder type applying right identity element. +leftPh :: Relation (p, ()) r -> Relation p r +leftPh = unsafeCastPlaceHolder + +-- | Generate SQL string from 'Relation' with configuration. +sqlFromRelationWith :: Relation p r -> Config -> StringSQL +sqlFromRelationWith = configureQuery . (showSQL <$>) . untypeRelation + +-- | SQL string from 'Relation'. +sqlFromRelation :: Relation p r -> StringSQL +sqlFromRelation = (`sqlFromRelationWith` defaultConfig) + +-- | Dump internal structure tree. +dump :: Relation p r -> String +dump = show . (`configureQuery` defaultConfig) . untypeRelation + +instance Show (Relation p r) where + show = showStringSQL . sqlFromRelation diff --git a/src/Database/Relational/Monad/Class.hs b/src/Database/Relational/Monad/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Class.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Monad.Class +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines query building interface classes. +module Database.Relational.Monad.Class + ( -- * Query interface classes + MonadQualify (..), MonadRestrict (..), + MonadQuery (..), MonadAggregate (..), MonadPartition (..), + + all', distinct, + on, wheres, having, + ) where + +import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Relational.SqlSyntax + (Duplication (..), Predicate, Record, AggregateKey) + +import Database.Relational.Projectable (PlaceHolders) +import Database.Relational.Monad.BaseType (ConfigureQuery, Relation) + + +-- | Restrict context interface +class (Functor m, Monad m) => MonadRestrict c m where + -- | Add restriction to this context. + restrict :: Predicate c -- ^ 'Record' which represent restriction + -> m () -- ^ Restricted query context + +-- | Query building interface. +class (Functor m, Monad m, MonadQualify ConfigureQuery m) => MonadQuery m where + -- | Specify duplication. + setDuplication :: Duplication -> m () + -- | Add restriction to last join. + restrictJoin :: Predicate Flat -- ^ 'Record' which represent restriction + -> m () -- ^ Restricted query context + {- Haddock BUG? -} + -- | Join sub-query with place-holder parameter 'p'. query result is not 'Maybe'. + query' :: Relation p r + -> m (PlaceHolders p, Record Flat r) + -- | Join sub-query with place-holder parameter 'p'. Query result is 'Maybe'. + queryMaybe' :: Relation p r + -> m (PlaceHolders p, Record Flat (Maybe r)) + +-- | Lift interface from base qualify monad. +class (Functor q, Monad q, Functor m, Monad m) => MonadQualify q m where + -- | Lift from qualify monad 'q' into 'MonadQuery' m. + -- Qualify monad qualifies table form 'SubQuery'. + liftQualify :: q a -> m a + +instance (Functor q, Monad q) => MonadQualify q q where + liftQualify = id + +-- | Aggregated query building interface extends 'MonadQuery'. +class MonadQuery m => MonadAggregate m where + -- | Add /GROUP BY/ term into context and get aggregated record. + groupBy :: Record Flat r -- ^ Record to add into group by + -> m (Record Aggregated r) -- ^ Result context and aggregated record + -- | Add /GROUP BY/ term into context and get aggregated record. Non-traditional group-by version. + groupBy' :: AggregateKey (Record Aggregated r) -- ^ Key to aggretate for non-traditional group-by interface + -> m (Record Aggregated r) -- ^ Result context and aggregated record + +-- | Window specification building interface. +class Monad m => MonadPartition c m where + -- | Add /PARTITION BY/ term into context. + partitionBy :: Record c r -> m () + +-- | Specify ALL attribute to query context. +all' :: MonadQuery m => m () +all' = setDuplication All + +-- | Specify DISTINCT attribute to query context. +distinct :: MonadQuery m => m () +distinct = setDuplication Distinct + +-- | Add restriction to last join. Record type version. +on :: MonadQuery m => Predicate Flat -> m () +on = restrictJoin + +-- | Add restriction to this not aggregated query. +wheres :: MonadRestrict Flat m => Predicate Flat -> m () +wheres = restrict + +-- | Add restriction to this aggregated query. Aggregated Record type version. +having :: MonadRestrict Aggregated m => Predicate Aggregated -> m () +having = restrict diff --git a/src/Database/Relational/Monad/Register.hs b/src/Database/Relational/Monad/Register.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Register.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Database.Relational.Monad.Register +-- Copyright : 2015-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about assignment monad type to build insert statement. +module Database.Relational.Monad.Register ( + -- * Monad to register target records. + Register, + + extract, + ) where + +import Database.Relational.Internal.Config (Config) +import Database.Relational.SqlSyntax (Assignment) + +import Database.Relational.Table (Table) +import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery) +import Database.Relational.Monad.Trans.Assigning (Assignings, extractAssignments) + + +-- | Target register monad type used from insert statement. +type Register r = Assignings r ConfigureQuery + +-- | Run 'InsertStatement'. +extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> [Assignment]) +extract = configureQuery . extractAssignments diff --git a/src/Database/Relational/Monad/Restrict.hs b/src/Database/Relational/Monad/Restrict.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Restrict.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Monad.Restrict ( + -- * Monad to restrict target records. + Restrict, RestrictedStatement, + + -- restricted, + extract + ) where + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.Internal.Config (Config) +import Database.Relational.SqlSyntax (Predicate, Record) + +import Database.Relational.Monad.Trans.Restricting + (Restrictings, extractRestrict) +import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery) + + +-- | Restrict only monad type used from update statement and delete statement. +type Restrict = Restrictings Flat ConfigureQuery + +-- | RestrictedStatement type synonym. +-- Record type 'r' must be +-- the same as 'Restrictings' type parameter 'r'. +type RestrictedStatement r a = Record Flat r -> Restrict a + +-- -- | 'return' of 'Restrict' +-- restricted :: a -> Restrict a +-- restricted = restrict . Identity + +-- | Run 'Restrict' to get 'QueryRestriction'. +extract :: Restrict a -> Config -> (a, [Predicate Flat]) +extract = configureQuery . extractRestrict diff --git a/src/Database/Relational/Monad/Simple.hs b/src/Database/Relational/Monad/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Simple.hs @@ -0,0 +1,67 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Monad.Simple +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about simple (not-aggregated) query type. +module Database.Relational.Monad.Simple ( + -- * Simple query + QuerySimple, SimpleQuery, + + simple, + + toSQL, + toSubQuery, + ) where + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax + (Duplication, OrderingTerm, JoinProduct, Predicate, Record, + SubQuery, flatSubQuery, ) +import qualified Database.Relational.SqlSyntax as Syntax + +import qualified Database.Relational.Record as Record +import Database.Relational.Monad.Trans.Join (join') +import Database.Relational.Monad.Trans.Restricting (restrictings) +import Database.Relational.Monad.Trans.Ordering + (Orderings, orderings, extractOrderingTerms) +import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig) +import Database.Relational.Monad.Type (QueryCore, extractCore, OrderedQuery) +import Database.Relational.Projectable (PlaceHolders) + + +-- | Simple (not-aggregated) query monad type. +type QuerySimple = Orderings Flat QueryCore + +-- | Simple (not-aggregated) query type. 'SimpleQuery'' p r == 'QuerySimple' ('PlaceHolders' p, 'Record' r). +type SimpleQuery p r = OrderedQuery Flat QueryCore p r + +-- | Lift from qualified table forms into 'QuerySimple'. +simple :: ConfigureQuery a -> QuerySimple a +simple = orderings . restrictings . join' + +extract :: SimpleQuery p r + -> ConfigureQuery (((((PlaceHolders p, Record Flat r), [OrderingTerm]), [Predicate Flat]), + JoinProduct), Duplication) +extract = extractCore . extractOrderingTerms + +-- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation. +toSQL :: SimpleQuery p r -- ^ 'SimpleQuery' to run + -> ConfigureQuery String -- ^ Result SQL string with 'Qualify' computation +toSQL = fmap Syntax.toSQL . toSubQuery + +-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. +toSubQuery :: SimpleQuery p r -- ^ 'SimpleQuery'' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation +toSubQuery q = do + (((((_ph, pj), ot), rs), pd), da) <- extract q + c <- askConfig + return $ flatSubQuery c (Record.untype pj) da pd rs ot diff --git a/src/Database/Relational/Monad/Trans/Aggregating.hs b/src/Database/Relational/Monad/Trans/Aggregating.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Aggregating.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Monad.Trans.Aggregating + ( -- * Transformer into aggregated query + Aggregatings, aggregatings, + + AggregatingSetT, AggregatingSetListT, AggregatingPowerSetT, PartitioningSetT, + + -- * Result + extractAggregateTerms, + + -- * Grouping sets support + AggregatingSet, AggregatingPowerSet, AggregatingSetList, PartitioningSet, + key, key', set, + bkey, rollup, cube, groupingSets, + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.DList (DList, toList) + +import Data.Functor.Identity (Identity (runIdentity)) + +import Database.Relational.Internal.ContextType + (Flat, Aggregated, Set, Power, SetList) +import Database.Relational.SqlSyntax + (Record, + AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, + AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets, + AggregateKey, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey) + +import qualified Database.Relational.Record as Record +import Database.Relational.Monad.Class + (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) + + +-- | Type to accumulate aggregating context. +-- Type 'ac' is aggregating-context type like aggregating key set building, +-- aggregating key sets set building and partition key set building. +-- Type 'at' is aggregating term type. +newtype Aggregatings ac at m a = + Aggregatings (WriterT (DList at) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Aggregatings'. +aggregatings :: Monad m => m a -> Aggregatings ac at m a +aggregatings = lift + +-- | Context type building one grouping set. +type AggregatingSetT = Aggregatings Set AggregateElem + +-- | Context type building grouping sets list. +type AggregatingSetListT = Aggregatings SetList AggregateSet + +-- | Context type building power group set. +type AggregatingPowerSetT = Aggregatings Power AggregateBitKey + +-- | Context type building partition keys set. +type PartitioningSetT c = Aggregatings c AggregateColumnRef + +-- | Aggregated 'MonadRestrict'. +instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where + restrict = aggregatings . restrict + +-- | Aggregated 'MonadQualify'. +instance MonadQualify q m => MonadQualify q (AggregatingSetT m) where + liftQualify = aggregatings . liftQualify + +-- | Aggregated 'MonadQuery'. +instance MonadQuery m => MonadQuery (AggregatingSetT m) where + setDuplication = aggregatings . setDuplication + restrictJoin = aggregatings . restrictJoin + query' = aggregatings . query' + queryMaybe' = aggregatings . queryMaybe' + +unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m () +unsafeAggregateWithTerm = Aggregatings . tell . pure + +aggregateKey :: Monad m => AggregateKey a -> Aggregatings ac AggregateElem m a +aggregateKey k = do + unsafeAggregateWithTerm $ aggregateKeyElement k + return $ aggregateKeyRecord k + +-- | Aggregated query instance. +instance MonadQuery m => MonadAggregate (AggregatingSetT m) where + groupBy p = do + mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Record.columns p] + return $ Record.unsafeToAggregated p + groupBy' = aggregateKey + +-- | Partition clause instance +instance Monad m => MonadPartition c (PartitioningSetT c m) where + partitionBy = mapM_ unsafeAggregateWithTerm . Record.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 Record. +key :: Record Flat r + -> AggregatingSet (Record Aggregated (Maybe r)) +key p = do + mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- Record.columns p] + return . Record.just $ Record.unsafeToAggregated p + +-- | Specify key of single grouping set. +key' :: AggregateKey a + -> AggregatingSet a +key' = aggregateKey + +-- | Finalize and specify single grouping set. +set :: AggregatingSet a + -> AggregatingSetList a +set s = do + let (p, c) = second aggregateGroupingSet . extractTermList $ s + unsafeAggregateWithTerm c + return p + +-- | Specify key of rollup and cube power set. +bkey :: Record Flat r + -> AggregatingPowerSet (Record Aggregated (Maybe r)) +bkey p = do + unsafeAggregateWithTerm . aggregatePowerKey $ Record.columns p + return . Record.just $ Record.unsafeToAggregated p + +finalizePower :: ([AggregateBitKey] -> AggregateElem) + -> AggregatingPowerSet a -> AggregateKey a +finalizePower finalize pow = unsafeAggregateKey . second finalize . extractTermList $ pow + +-- | Finalize grouping power set as rollup power set. +rollup :: AggregatingPowerSet a -> AggregateKey a +rollup = finalizePower aggregateRollup + +-- | Finalize grouping power set as cube power set. +cube :: AggregatingPowerSet a -> AggregateKey a +cube = finalizePower aggregateCube + +-- | Finalize grouping set list. +groupingSets :: AggregatingSetList a -> AggregateKey a +groupingSets = unsafeAggregateKey . second aggregateSets . extractTermList diff --git a/src/Database/Relational/Monad/Trans/Assigning.hs b/src/Database/Relational/Monad/Trans/Assigning.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Assigning.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Monad.Trans.Assigning ( + -- * Transformer into context with assignments + Assignings, assignings, + + -- * API of context with assignments + assignTo, (<-#), AssignTarget, + + -- * Result SQL set clause + extractAssignments + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.Monoid (mconcat) +import Data.DList (DList, toList) + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax (Record, Assignment) + +import Database.Relational.Pi (Pi) +import Database.Relational.Table (Table, recordWidth) +import qualified Database.Relational.Record as Record +import Database.Relational.Monad.Class (MonadQualify (..), MonadRestrict(..)) + + +-- | Type to accumulate assigning context. +-- Type 'r' is table record type. +newtype Assignings r m a = + Assignings (WriterT (Table r -> DList Assignment) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Assignings' +assignings :: Monad m => m a -> Assignings r m a +assignings = lift + +-- | 'MonadRestrict' with assigning. +instance MonadRestrict c m => MonadRestrict c (Assignings r m) where + restrict = assignings . restrict + +-- | 'MonadQualify' with assigning. +instance MonadQualify q m => MonadQualify q (Assignings r m) where + liftQualify = assignings . liftQualify + +-- | Target of assignment. +type AssignTarget r v = Pi r v + +targetRecord :: AssignTarget r v -> Table r -> Record Flat v +targetRecord pi' tbl = Record.wpi (recordWidth tbl) (Record.unsafeFromTable tbl) pi' + +-- | Add an assignment. +assignTo :: Monad m => Record Flat v -> AssignTarget r v -> Assignings r m () +assignTo vp target = Assignings . tell + $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where + leftsR = Record.columns . targetRecord target + rights = Record.columns vp + +-- | Add and assginment. +(<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m () +(<-#) = flip assignTo + +infix 4 <-# + +-- | Run 'Assignings' to get 'Assignments' +extractAssignments :: (Monad m, Functor m) + => Assignings r m a + -> m (a, Table r -> [Assignment]) +extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac diff --git a/src/Database/Relational/Monad/Trans/Config.hs b/src/Database/Relational/Monad/Trans/Config.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Config.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Monad.Trans.Config +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which requires query generate configuration. +module Database.Relational.Monad.Trans.Config ( + -- * Transformer into query with configuration + QueryConfig, queryConfig, + runQueryConfig, askQueryConfig + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) +import Control.Applicative (Applicative) + +import Database.Relational.Internal.Config (Config) + + +-- | 'ReaderT' type to require query generate configuration. +newtype QueryConfig m a = + QueryConfig (ReaderT Config m a) + deriving (Monad, Functor, Applicative) + +-- | Run 'QueryConfig' to expand with configuration +runQueryConfig :: QueryConfig m a -> Config -> m a +runQueryConfig (QueryConfig r) = runReaderT r + +-- | Lift to 'QueryConfig'. +queryConfig :: Monad m => m a -> QueryConfig m a +queryConfig = QueryConfig . lift + +-- | Read configuration. +askQueryConfig :: Monad m => QueryConfig m Config +askQueryConfig = QueryConfig ask diff --git a/src/Database/Relational/Monad/Trans/Join.hs b/src/Database/Relational/Monad/Trans/Join.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Join.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Monad.Trans.Join + ( -- * Transformer into join query + QueryJoin, join', + + -- * Result + extractProduct, + + -- * Unsafe API + unsafeSubQueryWithAttr, + ) where + +import Prelude hiding (product) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Monad.Trans.State (modify, StateT, runStateT) +import Control.Applicative (Applicative, (<$>)) +import Control.Arrow (second, (***)) +import Data.Maybe (fromMaybe) +import Data.Monoid (Last (Last, getLast)) + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax + (Duplication (All), NodeAttr (Just', Maybe), Predicate, Record, + SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, ) + +import Database.Relational.Monad.Trans.JoinState + (JoinContext, primeJoinContext, updateProduct, joinProduct) +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable (PlaceHolders, unsafeAddPlaceHolders) +import Database.Relational.Monad.BaseType (ConfigureQuery, qualifyQuery, Relation, untypeRelation) +import Database.Relational.Monad.Class (MonadQualify (..), MonadQuery (..)) + + +-- | 'StateT' type to accumulate join product context. +newtype QueryJoin m a = + QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a) + deriving (Monad, Functor, Applicative) + +instance MonadTrans QueryJoin where + lift = QueryJoin . lift . lift + +-- | Lift to 'QueryJoin' +join' :: Monad m => m a -> QueryJoin m a +join' = lift + +-- | Unsafely update join product context. +updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m () +updateContext = QueryJoin . modify + +-- | Add last join product restriction. +updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m () +updateJoinRestriction e = updateContext (updateProduct d) where + d Nothing = error "on: Product is empty! Restrict target product is not found!" + d (Just pt) = restrictProduct pt e + +instance MonadQualify q m => MonadQualify q (QueryJoin m) where + liftQualify = join' . liftQualify + +-- | Joinable query instance. +instance MonadQuery (QueryJoin ConfigureQuery) where + setDuplication = QueryJoin . lift . tell . Last . Just + restrictJoin = updateJoinRestriction + query' = queryWithAttr Just' + queryMaybe' pr = do + (ph, pj) <- queryWithAttr Maybe pr + return (ph, Record.just pj) + +-- | Unsafely join sub-query with this query. +unsafeSubQueryWithAttr :: Monad q + => NodeAttr -- ^ Attribute maybe or just + -> Qualified SubQuery -- ^ 'SubQuery' to join + -> QueryJoin q (Record c r) -- ^ Result joined context and record of 'SubQuery' result. +unsafeSubQueryWithAttr attr qsub = do + updateContext (updateProduct (`growProduct` (attr, qsub))) + return $ Record.unsafeFromQualifiedSubQuery qsub + +-- | Basic monadic join operation using 'MonadQuery'. +queryWithAttr :: NodeAttr + -> Relation p r + -> QueryJoin ConfigureQuery (PlaceHolders p, Record c r) +queryWithAttr attr = unsafeAddPlaceHolders . run where + run rel = do + q <- liftQualify $ do + sq <- untypeRelation rel + qualifyQuery sq + unsafeSubQueryWithAttr attr q + +-- | Run 'QueryJoin' to get 'JoinProduct' +extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication) +extractProduct (QueryJoin s) = (second joinProduct *** (fromMaybe All . getLast)) + <$> runWriterT (runStateT s primeJoinContext) diff --git a/src/Database/Relational/Monad/Trans/JoinState.hs b/src/Database/Relational/Monad/Trans/JoinState.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/JoinState.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Database.Relational.Monad.Trans.JoinState +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides state definition for +-- "Database.Relational.Monad.Trans.Join". +-- +-- This is not public interface. +module Database.Relational.Monad.Trans.JoinState ( + -- * Join context + JoinContext, primeJoinContext, updateProduct, joinProduct + ) where + +import Prelude hiding (product) +import Data.DList (DList, toList) + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax (JoinProduct, Node, Predicate) +import qualified Database.Relational.SqlSyntax as Product + + +-- | JoinContext type for QueryJoin. +newtype JoinContext = + JoinContext + { product :: Maybe (Node (DList (Predicate Flat))) + } + +-- | Initial 'JoinContext'. +primeJoinContext :: JoinContext +primeJoinContext = JoinContext Nothing + +-- | Update product of 'JoinContext'. +updateProduct :: (Maybe (Node (DList (Predicate Flat))) -> Node (DList (Predicate Flat))) + -> JoinContext + -> JoinContext +updateProduct uf ctx = ctx { product = Just . uf . product $ ctx } + +-- | Finalize context to extract accumulated query product. +joinProduct :: JoinContext -> JoinProduct +joinProduct = fmap (fmap toList . Product.nodeTree) . product diff --git a/src/Database/Relational/Monad/Trans/Ordering.hs b/src/Database/Relational/Monad/Trans/Ordering.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Ordering.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Monad.Trans.Ordering ( + -- * Transformer into query with ordering + Orderings, orderings, + + -- * API of query with ordering + orderBy', orderBy, asc, desc, + + -- * Result + extractOrderingTerms + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.DList (DList, toList) + +import Database.Relational.SqlSyntax + (Order (..), Nulls (..), OrderingTerm, Record) + +import qualified Database.Relational.Record as Record +import Database.Relational.Monad.Class + (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) + + +-- | Type to accumulate ordering context. +-- Type 'c' is ordering term record context type. +newtype Orderings c m a = + Orderings (WriterT (DList OrderingTerm) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Orderings'. +orderings :: Monad m => m a -> Orderings c m a +orderings = lift + +-- | 'MonadRestrict' with ordering. +instance MonadRestrict rc m => MonadRestrict rc (Orderings c m) where + restrict = orderings . restrict + +-- | 'MonadQualify' with ordering. +instance MonadQualify q m => MonadQualify q (Orderings c m) where + liftQualify = orderings . liftQualify + +-- | 'MonadQuery' with ordering. +instance MonadQuery m => MonadQuery (Orderings c m) where + setDuplication = orderings . setDuplication + restrictJoin = orderings . restrictJoin + query' = orderings . query' + queryMaybe' = orderings . queryMaybe' + +-- | 'MonadAggregate' with ordering. +instance MonadAggregate m => MonadAggregate (Orderings c m) where + groupBy = orderings . groupBy + groupBy' = orderings . groupBy' + +-- | 'MonadPartition' with ordering. +instance MonadPartition c m => MonadPartition c (Orderings c m) where + partitionBy = orderings . partitionBy + +-- | Add ordering terms. +updateOrderBys :: Monad m + => (Order, Maybe Nulls) -- ^ Order direction + -> Record c t -- ^ Ordering terms to add + -> Orderings c m () -- ^ Result context with ordering +updateOrderBys opair p = Orderings . mapM_ tell $ terms where + terms = curry pure opair `map` Record.columns p + +-- | Add ordering terms with null ordering. +orderBy' :: Monad m + => Record c t -- ^ Ordering terms to add + -> Order -- ^ Order direction + -> Nulls -- ^ Order of null + -> Orderings c m () -- ^ Result context with ordering +orderBy' p o n = updateOrderBys (o, Just n) p + +-- | Add ordering terms. +orderBy :: Monad m + => Record c t -- ^ Ordering terms to add + -> Order -- ^ Order direction + -> Orderings c m () -- ^ Result context with ordering +orderBy p o = updateOrderBys (o, Nothing) p + +-- | Add ascendant ordering term. +asc :: Monad m + => Record c t -- ^ Ordering terms to add + -> Orderings c m () -- ^ Result context with ordering +asc = updateOrderBys (Asc, Nothing) + +-- | Add descendant ordering term. +desc :: Monad m + => Record c t -- ^ Ordering terms to add + -> Orderings c m () -- ^ Result context with ordering +desc = updateOrderBys (Desc, Nothing) + +-- | Run 'Orderings' to get 'OrderingTerms' +extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, [OrderingTerm]) +extractOrderingTerms (Orderings oc) = second toList <$> runWriterT oc diff --git a/src/Database/Relational/Monad/Trans/Qualify.hs b/src/Database/Relational/Monad/Trans/Qualify.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Qualify.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.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.Monad.Trans.Qualify ( + -- * Qualify monad + Qualify, qualify, + evalQualifyPrime, qualifyQuery + ) where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State (StateT, runStateT, get, modify) +import Control.Applicative (Applicative) +import Control.Monad (liftM, ap) + +import qualified Database.Relational.SqlSyntax as Syntax + + +-- | Monad type to qualify SQL table forms. +newtype Qualify m a = + Qualify (StateT Int m a) + deriving (Monad, Functor, Applicative) + +-- | Run qualify monad with initial state to get only result. +evalQualifyPrime :: Monad m => Qualify m a -> m a +evalQualifyPrime (Qualify s) = fst `liftM` runStateT s 0 {- primary alias id -} + +-- | Generated new qualifier on internal state. +newAlias :: Monad m => Qualify m Syntax.Qualifier +newAlias = Qualify $ do + ai <- Syntax.Qualifier `liftM` get + modify (+ 1) + return ai + +-- | Lift to 'Qualify' +qualify :: Monad m => m a -> Qualify m a +qualify = Qualify . lift + +-- | Get qualifyed table form query. +qualifyQuery :: Monad m + => query -- ^ Query to qualify + -> Qualify m (Syntax.Qualified query) -- ^ Result with updated state +qualifyQuery query = + Syntax.qualify `liftM` newAlias `ap` return query diff --git a/src/Database/Relational/Monad/Trans/Restricting.hs b/src/Database/Relational/Monad/Trans/Restricting.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Trans/Restricting.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Monad.Trans.Restricting +-- Copyright : 2014-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which lift to basic 'MonadQuery'. +module Database.Relational.Monad.Trans.Restricting ( + -- * Transformer into restricted context + Restrictings, restrictings, + + -- * Result + extractRestrict + ) where + +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) +import Control.Applicative (Applicative, pure, (<$>)) +import Control.Arrow (second) +import Data.DList (DList, toList) + +import Database.Relational.SqlSyntax (Predicate) + +import Database.Relational.Monad.Class + (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) + + +-- | Type to accumulate query restrictions. +-- Type 'c' is context tag of restriction building like +-- Flat (where) or Aggregated (having). +newtype Restrictings c m a = + Restrictings (WriterT (DList (Predicate c)) m a) + deriving (MonadTrans, Monad, Functor, Applicative) + +-- | Lift to 'Restrictings' +restrictings :: Monad m => m a -> Restrictings c m a +restrictings = lift + +-- | Add whole query restriction. +updateRestriction :: Monad m => Predicate c -> Restrictings c m () +updateRestriction = Restrictings . tell . pure + +-- | 'MonadRestrict' instance. +instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where + restrict = updateRestriction + +-- | Restricted 'MonadQualify' instance. +instance MonadQualify q m => MonadQualify q (Restrictings c m) where + liftQualify = restrictings . liftQualify + +-- | Restricted 'MonadQuery' instance. +instance MonadQuery q => MonadQuery (Restrictings c q) where + setDuplication = restrictings . setDuplication + restrictJoin = restrictings . restrictJoin + query' = restrictings . query' + queryMaybe' = restrictings . queryMaybe' + +-- | Resticted 'MonadAggregate' instance. +instance MonadAggregate m => MonadAggregate (Restrictings c m) where + groupBy = restrictings . groupBy + groupBy' = restrictings . groupBy' + +-- | Run 'Restrictings' to get 'QueryRestriction' +extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, [Predicate c]) +extractRestrict (Restrictings rc) = second toList <$> runWriterT rc diff --git a/src/Database/Relational/Monad/Type.hs b/src/Database/Relational/Monad/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Type.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Database.Relational.Monad.Type +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines core query type. +module Database.Relational.Monad.Type + ( -- * Core query monad + QueryCore, extractCore, + OrderedQuery, + ) where + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax + (Duplication, Record, JoinProduct, Predicate, ) + +import Database.Relational.Projectable (PlaceHolders) +import Database.Relational.Monad.BaseType (ConfigureQuery) +import Database.Relational.Monad.Trans.Join (QueryJoin, extractProduct) +import Database.Relational.Monad.Trans.Restricting (Restrictings, extractRestrict) +import Database.Relational.Monad.Trans.Ordering (Orderings) + + +-- | Core query monad type used from flat(not-aggregated) query and aggregated query. +type QueryCore = Restrictings Flat (QueryJoin ConfigureQuery) + +-- | Extract 'QueryCore' computation. +extractCore :: QueryCore a + -> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication) +extractCore = extractProduct . extractRestrict + +-- | OrderedQuery monad type with placeholder type 'p'. Record must be the same as 'Orderings' context type parameter 'c'. +type OrderedQuery c m p r = Orderings c m (PlaceHolders p, Record c r) diff --git a/src/Database/Relational/Monad/Unique.hs b/src/Database/Relational/Monad/Unique.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Monad/Unique.hs @@ -0,0 +1,59 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Monad.Unique +-- Copyright : 2014-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains definitions about unique query type +-- to support scalar queries. +module Database.Relational.Monad.Unique + ( QueryUnique, unsafeUniqueSubQuery, + toSubQuery, + ) where + +import Control.Applicative (Applicative) + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax + (Duplication, Record, JoinProduct, NodeAttr, + SubQuery, Predicate, Qualified, ) + +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable (PlaceHolders) +import Database.Relational.Monad.Class (MonadQualify, MonadQuery) +import Database.Relational.Monad.Trans.Join (unsafeSubQueryWithAttr) +import Database.Relational.Monad.Trans.Restricting (restrictings) +import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig) +import Database.Relational.Monad.Type (QueryCore, extractCore) +import Database.Relational.SqlSyntax (flatSubQuery) + + +-- | Unique query monad type. +newtype QueryUnique a = QueryUnique (QueryCore a) + deriving (MonadQualify ConfigureQuery, MonadQuery, Monad, Applicative, Functor) + +-- | Unsafely join sub-query with this unique query. +unsafeUniqueSubQuery :: NodeAttr -- ^ Attribute maybe or just + -> Qualified SubQuery -- ^ 'SubQuery' to join + -> QueryUnique (Record c r) -- ^ Result joined context and record of 'SubQuery' result. +unsafeUniqueSubQuery a = QueryUnique . restrictings . unsafeSubQueryWithAttr a + +extract :: QueryUnique a + -> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication) +extract (QueryUnique c) = extractCore c + +-- | Run 'SimpleQuery' to get 'SubQuery' with 'Qualify' computation. +toSubQuery :: QueryUnique (PlaceHolders p, Record c r) -- ^ 'QueryUnique' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation +toSubQuery q = do + ((((_ph, pj), rs), pd), da) <- extract q + c <- askConfig + return $ flatSubQuery c (Record.untype pj) da pd rs [] diff --git a/src/Database/Relational/Pi.hs b/src/Database/Relational/Pi.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Pi.hs @@ -0,0 +1,42 @@ +-- | +-- Module : Database.Relational.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.Pi ( + -- * Projection path + Pi, (<.>), (), (), + + id', fst', snd' + ) where + +import qualified Control.Category as Category +import Database.Record + (PersistableWidth, persistableWidth, PersistableRecordWidth) +import Database.Record.Persistable + (runPersistableRecordWidth) + +import Database.Relational.Pi.Unsafe + (Pi, (<.>), (), (), 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 diff --git a/src/Database/Relational/Pi/Unsafe.hs b/src/Database/Relational/Pi/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Pi/Unsafe.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.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.Pi.Unsafe ( + -- * Projection path + Pi, + + width', width, + + (<.>), (), (), + + pi, + + definePi, defineDirectPi', defineDirectPi, + + unsafeExpandIndexes', + unsafeExpandIndexes + ) where + +import Prelude hiding (pi, (.), id) +import Control.Category (Category (..), (>>>)) +import Data.Array (listArray, (!)) +import Data.Functor.ProductIsomorphic + (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), + ProductIsoEmpty, pureE, peRight, peLeft, ) + +import Database.Record.Persistable + (PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, + PersistableWidth (persistableWidth), maybeWidth) + + +-- | Projection path primary structure type. +data Pi' r0 r1 = Leftest Int + | Map [Int] + +unsafePiAppend' :: Pi' a b' -> Pi' b c' -> Pi' a c +unsafePiAppend' = d where + d (Leftest i) (Leftest j) = Leftest $ i + j + d (Leftest i) (Map js) = Map $ map (i +) js + d (Map is) (Leftest j) = Map $ drop j is + d (Map is) (Map js) = Map [ is' ! j | j <- js ] where + is' = listArray (0, length is) is + +-- | Projection path from type 'r0' into type 'r1'. +-- This type also indicate key object which type is 'r1' for record type 'r0'. +newtype Pi r0 r1 = Pi { runPi :: PersistableRecordWidth r0 -> (Pi' r0 r1, PersistableRecordWidth r1) } + +instance PersistableWidth r0 => Show (Pi r0 r1) where + show p = unwords ["Pi", show $ unsafeExpandIndexes p] + +unsafePiAppend :: (PersistableRecordWidth b' -> PersistableRecordWidth b) + -> (PersistableRecordWidth c' -> PersistableRecordWidth c) + -> Pi a b' -> Pi b c' -> Pi a c +unsafePiAppend wbf wcf (Pi f) (Pi g) = Pi $ \wa -> + let (pab, wb) = f wa + (pbc, wc) = g $ wbf wb + in (pab `unsafePiAppend'` pbc, wcf wc) + +-- | 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) + +-- | 'Pi' with zero width which projects to unit +pzero :: Pi a () +pzero = Pi $ \_ -> (Map [], persistableWidth) + +-- | Map projection path 'Pi' which has record result type. +instance ProductIsoFunctor (Pi a) where + _ |$| p = unsafeCast p + +-- | Compose projection path 'Pi' which has record result type using applicative style. +instance ProductIsoApplicative (Pi a) where + pureP _ = unsafeCast pzero + pab |*| pb = + Pi $ \wr -> + let (_, wab) = runPi pab wr + (_, wb) = runPi pb wr in + (Map $ unsafeExpandIndexes' wr pab ++ unsafeExpandIndexes' wr pb, + wab |*| wb) + +instance ProductIsoEmpty (Pi a) () where + pureE = pzero + peRight = unsafeCast + peLeft = unsafeCast + +-- | Get record width proof object. +width' :: PersistableWidth r => Pi r ct -> PersistableRecordWidth ct +width' (Pi f) = snd $ f persistableWidth + +-- | Get record width. +width :: PersistableWidth r => Pi r a -> Int +width = runPersistableRecordWidth . width' + +justWidth :: PersistableRecordWidth (Maybe a) -> PersistableRecordWidth a +justWidth = unsafeCastRecordWidth + + +instance Category Pi where + id = Pi $ \pw -> (Leftest 0, pw) + Pi fb . Pi fa = Pi $ \wa -> + let (pb, wb) = fa wa + (pc, wc) = fb wb + in (unsafePiAppend' pb pc, wc) + +-- | Compose projection path. +(<.>) :: Pi a b -> Pi b c -> Pi a c +(<.>) = (>>>) + +-- | Compose projection path. 'Maybe' phantom functor is 'map'-ed. +() :: Pi a (Maybe b) -> Pi b c -> Pi a (Maybe c) +() = unsafePiAppend justWidth maybeWidth + +-- | Compose projection path. 'Maybe' phantom functors are 'join'-ed like '>=>'. +() :: Pi a (Maybe b) -> Pi b (Maybe c) -> Pi a (Maybe c) +() = unsafePiAppend justWidth id + +infixl 8 <.>, , + +-- | Unsafely project untyped value list. +pi :: PersistableRecordWidth r0 -> Pi r0 r1 -> [a] -> [a] +pi w0 (Pi f) cs = d p' where + (p', w1) = f w0 + d (Leftest i) = take (runPersistableRecordWidth w1) . drop i $ cs + d (Map is) = [cs' ! i | i <- is] + cs' = listArray (0, length cs) cs + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +definePi' :: PersistableRecordWidth r1 + -> Int -- ^ Index of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +definePi' pw i = Pi $ \_ -> (Leftest i, pw) + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +-- Use inferred 'PersistableRecordWidth'. +definePi :: PersistableWidth r1 + => Int -- ^ Index of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +definePi = definePi' persistableWidth + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +defineDirectPi' :: PersistableRecordWidth r1 + -> [Int] -- ^ Indexes of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +defineDirectPi' pw is = Pi $ \_ -> (Map is, pw) + +-- | Unsafely define projection path from type 'r0' into type 'r1'. +-- Use inferred 'PersistableRecordWidth'. +defineDirectPi :: PersistableWidth r1 + => [Int] -- ^ Indexes of flat SQL value list + -> Pi r0 r1 -- ^ Result projection path +defineDirectPi = defineDirectPi' persistableWidth diff --git a/src/Database/Relational/Projectable.hs b/src/Database/Relational/Projectable.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Projectable.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Relational.Projectable +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines operators on various projected records. +module Database.Relational.Projectable ( + -- * Projectable from SQL strings + SqlContext (unsafeProjectSqlTerms), unsafeProjectSql', + unsafeProjectSql, + + -- * Records of values + value, + valueTrue, valueFalse, + values, + nothing, + + -- * Placeholders + PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders, + pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH, + + -- * Projectable into SQL strings + unsafeShowSql', unsafeShowSql, + + -- * Operators + (.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.), + + and', or', in', + + (.||.), (?||?), like, likeMaybe, like', likeMaybe', + (.+.), (.-.), (.*.), (./.), + (?+?), (?-?), (?*?), (?/?), + + isNothing, isJust, fromMaybe, + not', exists, + + negate', fromIntegral', showNum, + negateMaybe, fromIntegralMaybe, showNumMaybe, + + casesOrElse, casesOrElse', + caseSearch, caseSearchMaybe, case', caseMaybe, + + SqlBinOp, unsafeBinOp, unsafeUniOp, + + -- * Terms for Window function types + rank, denseRank, rowNumber, percentRank, cumeDist, + + -- * Zipping projections + projectZip, (><), + + -- * 'Maybe' type projecitoins + ProjectableMaybe (just, flattenMaybe), + ) where + +import Prelude hiding (pi) + +import Data.String (IsString) +import Data.Functor.ProductIsomorphic + (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), + ProductIsoEmpty, pureE, peRight, peLeft, ) + +import Language.SQL.Keyword (Keyword) +import qualified Language.SQL.Keyword as SQL + +import Database.Record + (PersistableWidth, persistableWidth, PersistableRecordWidth, + HasColumnConstraint, NotNull) +import Database.Record.Persistable (runPersistableRecordWidth) + +import Database.Relational.Internal.ContextType + (Flat, Aggregated, Exists, OverWindow) +import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) +import Database.Relational.SqlSyntax (Record, Predicate) +import qualified Database.Relational.SqlSyntax as Syntax + +import Database.Relational.Pure () +import Database.Relational.TupleInstances () +import Database.Relational.ProjectableClass + (ShowConstantTermsSQL, showConstantTermsSQL, ) +import Database.Relational.Record (RecordList) +import qualified Database.Relational.Record as Record + + +-- | Interface to project SQL terms unsafely. +class SqlContext c where + -- | Unsafely project from SQL expression terms. + unsafeProjectSqlTerms :: [StringSQL] + -> Record c t + +-- | Unsafely make 'Record' from SQL terms. +instance SqlContext Flat where + unsafeProjectSqlTerms = Record.unsafeFromSqlTerms + +-- | Unsafely make 'Record' from SQL terms. +instance SqlContext Aggregated where + unsafeProjectSqlTerms = Record.unsafeFromSqlTerms + +-- | Unsafely make 'Record' from SQL terms. +instance SqlContext OverWindow where + unsafeProjectSqlTerms = Record.unsafeFromSqlTerms + +class SqlContext c => OperatorContext c +instance OperatorContext Flat +instance OperatorContext Aggregated + + +-- | Unsafely Project single SQL term. +unsafeProjectSql' :: SqlContext c => StringSQL -> Record c t +unsafeProjectSql' = unsafeProjectSqlTerms . (:[]) + +-- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql'''. +unsafeProjectSql :: SqlContext c => String -> Record c t +unsafeProjectSql = unsafeProjectSql' . stringSQL + +-- | Record with polymorphic phantom type of SQL null value. Semantics of comparing is unsafe. +nothing :: (OperatorContext c, SqlContext c, PersistableWidth a) + => Record c (Maybe a) +nothing = proxyWidth persistableWidth + where + proxyWidth :: SqlContext c => PersistableRecordWidth a -> Record c (Maybe a) + proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL + +-- | Generate record with polymorphic type of SQL constant values from Haskell value. +value :: (ShowConstantTermsSQL t, OperatorContext c) => t -> Record c t +value = unsafeProjectSqlTerms . showConstantTermsSQL + +-- | Record with polymorphic type of SQL true value. +valueTrue :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool) +valueTrue = just $ value True + +-- | Record with polymorphic type of SQL false value. +valueFalse :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool) +valueFalse = just $ value False + +-- | RecordList with polymorphic type of SQL set value from Haskell list. +values :: (ShowConstantTermsSQL t, OperatorContext c) => [t] -> RecordList (Record c) t +values = Record.list . map value + + +-- | Unsafely generate SQL expression term from record object. +unsafeShowSql' :: Record c a -> StringSQL +unsafeShowSql' = Record.unsafeStringSql + +-- | Unsafely generate SQL expression string from record object. +-- String interface of 'unsafeShowSql''. +unsafeShowSql :: Record c a -- ^ Source record object + -> String -- ^ Result SQL expression string. +unsafeShowSql = showStringSQL . unsafeShowSql' + + +-- | Binary operator type for SQL String. +type SqlBinOp = Keyword -> Keyword -> Keyword + +-- | Unsafely make unary operator for records from SQL keyword. +unsafeUniOp :: SqlContext c2 + => (Keyword -> Keyword) -> Record c1 a -> Record c2 b +unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql' + +unsafeFlatUniOp :: SqlContext c + => Keyword -> Record c a -> Record c b +unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw) + +-- | Unsafely make binary operator for records from string binary operator. +unsafeBinOp :: SqlContext k + => SqlBinOp + -> Record k a -> Record k b -> Record k c +unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $ + op (unsafeShowSql' a) (unsafeShowSql' b) + +-- | Unsafely make binary operator to compare records from string binary operator. +compareBinOp :: SqlContext c + => SqlBinOp + -> Record c a -> Record c a -> Record c (Maybe Bool) +compareBinOp = unsafeBinOp + +-- | Unsafely make numrical binary operator for records from string binary operator. +monoBinOp :: SqlContext c + => SqlBinOp + -> Record c a -> Record c a -> Record c a +monoBinOp = unsafeBinOp + + +-- | Compare operator corresponding SQL /=/ . +(.=.) :: OperatorContext c + => Record c ft -> Record c ft -> Record c (Maybe Bool) +(.=.) = compareBinOp (SQL..=.) + +-- | Compare operator corresponding SQL / Record c ft -> Record c ft -> Record c (Maybe Bool) +(.<.) = compareBinOp (SQL..<.) + +-- | Compare operator corresponding SQL /<=/ . +(.<=.) :: OperatorContext c + => Record c ft -> Record c ft -> Record c (Maybe Bool) +(.<=.) = compareBinOp (SQL..<=.) + +-- | Compare operator corresponding SQL />/ . +(.>.) :: OperatorContext c + => Record c ft -> Record c ft -> Record c (Maybe Bool) +(.>.) = compareBinOp (SQL..>.) + +-- | Compare operator corresponding SQL />=/ . +(.>=.) :: OperatorContext c + => Record c ft -> Record c ft -> Record c (Maybe Bool) +(.>=.) = compareBinOp (SQL..>=.) + +-- | Compare operator corresponding SQL /<>/ . +(.<>.) :: OperatorContext c + => Record c ft -> Record c ft -> Record c (Maybe Bool) +(.<>.) = compareBinOp (SQL..<>.) + +-- | Logical operator corresponding SQL /AND/ . +and' :: OperatorContext c + => Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool) +and' = monoBinOp SQL.and + +-- | Logical operator corresponding SQL /OR/ . +or' :: OperatorContext c + => Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool) +or' = monoBinOp SQL.or + +-- | Logical operator corresponding SQL /NOT/ . +not' :: OperatorContext c + => Record c (Maybe Bool) -> Record c (Maybe Bool) +not' = unsafeFlatUniOp SQL.NOT + +-- | Logical operator corresponding SQL /EXISTS/ . +exists :: OperatorContext c + => RecordList (Record Exists) r -> Record c (Maybe Bool) +exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS + . Record.unsafeStringSqlList unsafeShowSql' + +-- | Concatinate operator corresponding SQL /||/ . +(.||.) :: OperatorContext c + => Record c a -> Record c a -> Record c a +(.||.) = unsafeBinOp (SQL..||.) + +-- | Concatinate operator corresponding SQL /||/ . Maybe type version. +(?||?) :: (OperatorContext c, IsString a) + => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) +(?||?) = unsafeBinOp (SQL..||.) + +unsafeLike :: OperatorContext c + => Record c a -> Record c b -> Record c (Maybe Bool) +unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE) + +-- | String-compare operator corresponding SQL /LIKE/ . +like' :: (OperatorContext c, IsString a) + => Record c a -> Record c a -> Record c (Maybe Bool) +x `like'` y = x `unsafeLike` y + +-- | String-compare operator corresponding SQL /LIKE/ . +likeMaybe' :: (OperatorContext c, IsString a) + => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe Bool) +x `likeMaybe'` y = x `unsafeLike` y + +-- | String-compare operator corresponding SQL /LIKE/ . +like :: (OperatorContext c, IsString a, ShowConstantTermsSQL a) + => Record c a -> a -> Record c (Maybe Bool) +x `like` a = x `like'` value a + +-- | String-compare operator corresponding SQL /LIKE/ . Maybe type version. +likeMaybe :: (OperatorContext c, IsString a, ShowConstantTermsSQL a) + => Record c (Maybe a) -> a -> Record c (Maybe Bool) +x `likeMaybe` a = x `unsafeLike` value a + +-- | Unsafely make number binary operator for records from SQL operator string. +monoBinOp' :: SqlContext c + => Keyword -> Record c a -> Record c a -> Record c a +monoBinOp' = monoBinOp . SQL.defineBinOp + +-- | Number operator corresponding SQL /+/ . +(.+.) :: (OperatorContext c, Num a) + => Record c a -> Record c a -> Record c a +(.+.) = monoBinOp' "+" + +-- | Number operator corresponding SQL /-/ . +(.-.) :: (OperatorContext c, Num a) + => Record c a -> Record c a -> Record c a +(.-.) = monoBinOp' "-" + +-- | Number operator corresponding SQL /// . +(./.) :: (OperatorContext c, Num a) + => Record c a -> Record c a -> Record c a +(./.) = monoBinOp' "/" + +-- | Number operator corresponding SQL /*/ . +(.*.) :: (OperatorContext c, Num a) + => Record c a -> Record c a -> Record c a +(.*.) = monoBinOp' "*" + +-- | Number negate uni-operator corresponding SQL /-/. +negate' :: (OperatorContext c, Num a) + => Record c a -> Record c a +negate' = unsafeFlatUniOp $ SQL.word "-" + +unsafeCastProjectable :: SqlContext c + => Record c a -> Record c b +unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql' + +-- | Number fromIntegral uni-operator. +fromIntegral' :: (SqlContext c, Integral a, Num b) + => Record c a -> Record c b +fromIntegral' = unsafeCastProjectable + +-- | Unsafely show number into string-like type in records. +showNum :: (SqlContext c, Num a, IsString b) + => Record c a -> Record c b +showNum = unsafeCastProjectable + +-- | Number operator corresponding SQL /+/ . +(?+?) :: (OperatorContext c, Num a) + => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) +(?+?) = monoBinOp' "+" + +-- | Number operator corresponding SQL /-/ . +(?-?) :: (OperatorContext c, Num a) + => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) +(?-?) = monoBinOp' "-" + +-- | Number operator corresponding SQL /// . +(?/?) :: (OperatorContext c, Num a) + => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) +(?/?) = monoBinOp' "/" + +-- | Number operator corresponding SQL /*/ . +(?*?) :: (OperatorContext c, Num a) + => Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a) +(?*?) = monoBinOp' "*" + +-- | Number negate uni-operator corresponding SQL /-/. +negateMaybe :: (OperatorContext c, Num a) + => Record c (Maybe a) -> Record c (Maybe a) +negateMaybe = unsafeFlatUniOp $ SQL.word "-" + +-- | Number fromIntegral uni-operator. +fromIntegralMaybe :: (SqlContext c, Integral a, Num b) + => Record c (Maybe a) -> Record c (Maybe b) +fromIntegralMaybe = unsafeCastProjectable + +-- | Unsafely show number into string-like type in records. +showNumMaybe :: (SqlContext c, Num a, IsString b) + => Record c (Maybe a) -> Record c (Maybe b) +showNumMaybe = unsafeCastProjectable + +-- | Search case operator correnponding SQL search /CASE/. +-- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ +caseSearch :: OperatorContext c + => [(Predicate c, Record c a)] -- ^ Each when clauses + -> Record c a -- ^ Else result record + -> Record c a -- ^ Result record +caseSearch = Syntax.caseSearch + +-- | Same as 'caseSearch', but you can write like `casesOrElse` . +casesOrElse :: OperatorContext c + => [(Predicate c, Record c a)] -- ^ Each when clauses + -> Record c a -- ^ Else result record + -> Record c a -- ^ Result record +casesOrElse = caseSearch + +-- | Null default version of 'caseSearch'. +caseSearchMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, PersistableWidth a) + => [(Predicate c, Record c (Maybe a))] -- ^ Each when clauses + -> Record c (Maybe a) -- ^ Result record +caseSearchMaybe cs = caseSearch cs nothing + +-- | Simple case operator correnponding SQL simple /CASE/. +-- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ +case' :: OperatorContext c + => Record c a -- ^ Record value to match + -> [(Record c a, Record c b)] -- ^ Each when clauses + -> Record c b -- ^ Else result record + -> Record c b -- ^ Result record +case' = Syntax.case' + +-- | Uncurry version of 'case'', and you can write like ... `casesOrElse'` . +casesOrElse' :: OperatorContext c + => (Record c a, [(Record c a, Record c b)]) -- ^ Record value to match and each when clauses list + -> Record c b -- ^ Else result record + -> Record c b -- ^ Result record +casesOrElse' = uncurry case' + +-- | Null default version of 'case''. +caseMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, PersistableWidth b) + => Record c a -- ^ Record value to match + -> [(Record c a, Record c (Maybe b))] -- ^ Each when clauses + -> Record c (Maybe b) -- ^ Result record +caseMaybe v cs = case' v cs nothing + +-- | Binary operator corresponding SQL /IN/ . +in' :: OperatorContext c + => Record c t -> RecordList (Record c) t -> Record c (Maybe Bool) +in' a lp = unsafeProjectSql' . SQL.paren + $ SQL.in' (unsafeShowSql' a) (Record.unsafeStringSqlList unsafeShowSql' lp) + +-- | Operator corresponding SQL /IS NULL/ , and extended against record types. +isNothing :: (OperatorContext c, HasColumnConstraint NotNull r) + => Record c (Maybe r) -> Predicate c +isNothing mr = unsafeProjectSql' $ + SQL.paren $ (SQL.defineBinOp SQL.IS) + (Record.unsafeStringSqlNotNullMaybe mr) SQL.NULL + +-- | Operator corresponding SQL /NOT (... IS NULL)/ , and extended against record type. +isJust :: (OperatorContext c, HasColumnConstraint NotNull r) + => Record c (Maybe r) -> Predicate c +isJust = not' . isNothing + +-- | Operator from maybe type using record extended 'isNull'. +fromMaybe :: (OperatorContext c, HasColumnConstraint NotNull r) + => Record c r -> Record c (Maybe r) -> Record c r +fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p + +unsafeUniTermFunction :: SqlContext c => Keyword -> Record c t +unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()") + +-- | /RANK()/ term. +rank :: Integral a => Record OverWindow a +rank = unsafeUniTermFunction SQL.RANK + +-- | /DENSE_RANK()/ term. +denseRank :: Integral a => Record OverWindow a +denseRank = unsafeUniTermFunction SQL.DENSE_RANK + +-- | /ROW_NUMBER()/ term. +rowNumber :: Integral a => Record OverWindow a +rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER + +-- | /PERCENT_RANK()/ term. +percentRank :: Record OverWindow Double +percentRank = unsafeUniTermFunction SQL.PERCENT_RANK + +-- | /CUME_DIST()/ term. +cumeDist :: Record OverWindow Double +cumeDist = unsafeUniTermFunction SQL.CUME_DIST + +-- | 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 = pureP () + +-- | No placeholder semantics. Same as `unitPlaceHolder` +unitPH :: PlaceHolders () +unitPH = pureP () + +-- | Unsafely cast placeholder parameter type. +unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b +unsafeCastPlaceHolders PlaceHolders = PlaceHolders + +-- | Provide scoped placeholder from width and return its parameter object. +pwPlaceholder :: SqlContext c + => PersistableRecordWidth a + -> (Record c a -> b) + -> (PlaceHolders a, b) +pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw) + where + projectPlaceHolder :: SqlContext c + => PersistableRecordWidth a + -> Record c a + projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth + +-- | Provide scoped placeholder and return its parameter object. +placeholder' :: (PersistableWidth t, SqlContext c) => (Record c t -> a) -> (PlaceHolders t, a) +placeholder' = pwPlaceholder persistableWidth + +-- | Provide scoped placeholder and return its parameter object. Monadic version. +placeholder :: (PersistableWidth t, SqlContext c, Monad m) => (Record c t -> m a) -> m (PlaceHolders t, a) +placeholder f = do + let (ph, ma) = placeholder' f + a <- ma + return (ph, a) + + +-- | Zipping projections. +projectZip :: ProductIsoApplicative p => p a -> p b -> p (a, b) +projectZip pa pb = (,) |$| pa |*| pb + +-- | Binary operator the same as 'projectZip'. +(><) :: ProductIsoApplicative p => p a -> p b -> p (a, b) +(><) = projectZip + +-- | Interface to control 'Maybe' of phantom type in records. +class ProjectableMaybe p where + -- | Cast record phantom type into 'Maybe'. + just :: p a -> p (Maybe a) + -- | Compose nested 'Maybe' phantom type on record. + flattenMaybe :: p (Maybe (Maybe a)) -> p (Maybe a) + +-- | Control phantom 'Maybe' type in placeholder parameters. +instance ProjectableMaybe PlaceHolders where + just = unsafeCastPlaceHolders + flattenMaybe = unsafeCastPlaceHolders + +-- | Control phantom 'Maybe' type in record type 'Record'. +instance ProjectableMaybe (Record c) where + just = Record.just + flattenMaybe = Record.flattenMaybe + +-- | Zipping except for identity element laws against placeholder parameter type. +instance ProductIsoEmpty PlaceHolders () where + pureE = unsafePlaceHolders + peRight = unsafeCastPlaceHolders + peLeft = unsafeCastPlaceHolders + +-- | Compose seed of record type 'PlaceHolders'. +instance ProductIsoFunctor PlaceHolders where + _ |$| PlaceHolders = PlaceHolders + +-- | Compose record type 'PlaceHolders' using applicative style. +instance ProductIsoApplicative PlaceHolders where + pureP _ = unsafeCastPlaceHolders unitPH + 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 >< diff --git a/src/Database/Relational/ProjectableClass.hs b/src/Database/Relational/ProjectableClass.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/ProjectableClass.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} + +-- | +-- Module : Database.Relational.ProjectableClass +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides interfaces to preserve constraints of +-- direct product projections. +module Database.Relational.ProjectableClass ( + -- * Literal SQL terms + 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.Internal.String (StringSQL) + + +-- | 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 diff --git a/src/Database/Relational/ProjectableExtended.hs b/src/Database/Relational/ProjectableExtended.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/ProjectableExtended.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.ProjectableExtended +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines operators on various projected records. +module Database.Relational.ProjectableExtended ( + -- * Projection for nested 'Maybe's + ProjectableFlattenMaybe (flatten), + + flattenPiMaybe, + + -- * Get narrower records + (!), (?!), (?!?), (!??), + + -- * Aggregate functions + unsafeAggregateOp, + count, + sum', sumMaybe, avg, avgMaybe, + max', maxMaybe, min', minMaybe, + every, any', some', + ) where + +import Prelude hiding (pi) + +import qualified Language.SQL.Keyword as SQL +import Database.Record (PersistableWidth) + +import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow) +import Database.Relational.SqlSyntax (Predicate, Record, ) + +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable + (unsafeUniOp, ProjectableMaybe (flattenMaybe), SqlContext) +import Database.Relational.Pi (Pi) + + +class AggregatedContext ac +instance AggregatedContext Aggregated +instance AggregatedContext OverWindow + +-- | Unsafely make aggregation uni-operator from SQL keyword. +unsafeAggregateOp :: (AggregatedContext ac, SqlContext ac) + => SQL.Keyword -> Record Flat a -> Record ac b +unsafeAggregateOp op = unsafeUniOp ((op SQL.<++>) . SQL.paren) + +-- | Aggregation function COUNT. +count :: (Integral b, AggregatedContext ac, SqlContext ac) + => Record Flat a -> Record ac b +count = unsafeAggregateOp SQL.COUNT + +-- | Aggregation function SUM. +sumMaybe :: (Num a, AggregatedContext ac, SqlContext ac) + => Record Flat (Maybe a) -> Record ac (Maybe a) +sumMaybe = unsafeAggregateOp SQL.SUM + +-- | Aggregation function SUM. +sum' :: (Num a, AggregatedContext ac, SqlContext ac) + => Record Flat a -> Record ac (Maybe a) +sum' = sumMaybe . Record.just + +-- | Aggregation function AVG. +avgMaybe :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac) + => Record Flat (Maybe a) -> Record ac (Maybe b) +avgMaybe = unsafeAggregateOp SQL.AVG + +-- | Aggregation function AVG. +avg :: (Num a, Fractional b, AggregatedContext ac, SqlContext ac) + => Record Flat a -> Record ac (Maybe b) +avg = avgMaybe . Record.just + +-- | Aggregation function MAX. +maxMaybe :: (Ord a, AggregatedContext ac, SqlContext ac) + => Record Flat (Maybe a) -> Record ac (Maybe a) +maxMaybe = unsafeAggregateOp SQL.MAX + +-- | Aggregation function MAX. +max' :: (Ord a, AggregatedContext ac, SqlContext ac) + => Record Flat a -> Record ac (Maybe a) +max' = maxMaybe . Record.just + +-- | Aggregation function MIN. +minMaybe :: (Ord a, AggregatedContext ac, SqlContext ac) + => Record Flat (Maybe a) -> Record ac (Maybe a) +minMaybe = unsafeAggregateOp SQL.MIN + +-- | Aggregation function MIN. +min' :: (Ord a, AggregatedContext ac, SqlContext ac) + => Record Flat a -> Record ac (Maybe a) +min' = minMaybe . Record.just + +-- | Aggregation function EVERY. +every :: (AggregatedContext ac, SqlContext ac) + => Predicate Flat -> Record ac (Maybe Bool) +every = unsafeAggregateOp SQL.EVERY + +-- | Aggregation function ANY. +any' :: (AggregatedContext ac, SqlContext ac) + => Predicate Flat -> Record ac (Maybe Bool) +any' = unsafeAggregateOp SQL.ANY + +-- | Aggregation function SOME. +some' :: (AggregatedContext ac, SqlContext ac) + => Predicate Flat -> Record ac (Maybe Bool) +some' = unsafeAggregateOp SQL.SOME + +-- | Get narrower record along with projection path. +(!) :: PersistableWidth a + => Record c a -- ^ Source 'Record' + -> Pi a b -- ^ Record path + -> Record c b -- ^ Narrower projected object +(!) = Record.pi + +-- | Get narrower record along with projection path +-- 'Maybe' phantom functor is 'map'-ed. +(?!) :: PersistableWidth a + => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type + -> Pi a b -- ^ Record path + -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' type result +(?!) = Record.piMaybe + +-- | Get narrower record along with projection path +-- and project into result record type. +-- Source record 'Maybe' phantom functor and projection path leaf 'Maybe' functor are 'join'-ed. +(?!?) :: PersistableWidth a + => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type + -> Pi a (Maybe b) -- ^ Record path. 'Maybe' type leaf + -> Record c (Maybe b) -- ^ Narrower projected object. 'Maybe' phantom type result +(?!?) = Record.piMaybe' + + +-- | Interface to compose phantom 'Maybe' nested type. +class ProjectableFlattenMaybe a b where + flatten :: ProjectableMaybe p => p a -> p b + +-- | Compose 'Maybe' type in record phantom type. +instance ProjectableFlattenMaybe (Maybe a) b + => ProjectableFlattenMaybe (Maybe (Maybe a)) b where + flatten = flatten . flattenMaybe + +-- | Not 'Maybe' type is not processed. +instance ProjectableFlattenMaybe (Maybe a) (Maybe a) where + flatten = id + +-- | Get narrower record with flatten leaf phantom Maybe types along with projection path. +flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c) + => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> Record cont c -- ^ Narrower 'Record'. Flatten 'Maybe' phantom type +flattenPiMaybe p = flatten . Record.piMaybe p + +-- | Get narrower record with flatten leaf phantom Maybe types along with projection path. +(!??) :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c) + => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type + -> Pi a b -- ^ Projection path + -> Record cont c -- ^ Narrower flatten and projected object. +(!??) = flattenPiMaybe + + +infixl 8 !, ?!, ?!?, !?? diff --git a/src/Database/Relational/Pure.hs b/src/Database/Relational/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Pure.hs @@ -0,0 +1,160 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.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 record values. +module Database.Relational.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.Internal.String (StringSQL, stringSQL, boolSQL) + +import Database.Relational.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 . boolSQL + +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 diff --git a/src/Database/Relational/Query.hs b/src/Database/Relational/Query.hs --- a/src/Database/Relational/Query.hs +++ b/src/Database/Relational/Query.hs @@ -1,94 +1,19 @@ -- | -- Module : Database.Relational.Query --- Copyright : 2013-2017 Kei Hibino +-- Copyright : 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 () +-- This module contains backword compatibility interface of +-- relational-query <= 0.9.* +module Database.Relational.Query + {-# DEPRECATED "Should switch namespace to Database.Relational" #-} + ( module Database.Relational, + module Database.Relational.Compat, + ) where -{-# ANN module "HLint: ignore Use import/export shortcut" #-} +import Database.Relational hiding (unsafeShowSql', unsafeShowSql, unsafeProjectSqlTerms, unsafeProjectSql) +import Database.Relational.Compat diff --git a/src/Database/Relational/Query/Arrow.hs b/src/Database/Relational/Query/Arrow.hs --- a/src/Database/Relational/Query/Arrow.hs +++ b/src/Database/Relational/Query/Arrow.hs @@ -1,448 +1,19 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- | -- Module : Database.Relational.Query.Arrow --- Copyright : 2015-2017 Kei Hibino +-- Copyright : 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 +-- This module contains backword compatibility interface of +-- relational-query <= 0.9.* +module Database.Relational.Query.Arrow + {-# DEPRECATED "Should switch namespace to Database.Relational.Arrow" #-} + ( module Database.Relational.Arrow, + module Database.Relational.Compat, + ) where --- | Same as 'Monadic.derivedDelete'. --- Make 'Update' from restrict statement arrow. -derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p -derivedDelete = Monadic.derivedDelete . runQueryA +import Database.Relational.Arrow hiding (unsafeShowSql', unsafeShowSql, unsafeProjectSqlTerms, unsafeProjectSql) +import Database.Relational.Compat diff --git a/src/Database/Relational/Query/BaseTH.hs b/src/Database/Relational/Query/BaseTH.hs deleted file mode 100644 --- a/src/Database/Relational/Query/BaseTH.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# 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] diff --git a/src/Database/Relational/Query/Component.hs b/src/Database/Relational/Query/Component.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Component.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | --- 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) diff --git a/src/Database/Relational/Query/Constraint.hs b/src/Database/Relational/Query/Constraint.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Constraint.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Context.hs b/src/Database/Relational/Query/Context.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Context.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Derives.hs b/src/Database/Relational/Query/Derives.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Derives.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Effect.hs b/src/Database/Relational/Query/Effect.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Effect.hs +++ /dev/null @@ -1,190 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Internal/BaseSQL.hs b/src/Database/Relational/Query/Internal/BaseSQL.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/BaseSQL.hs +++ /dev/null @@ -1,96 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Internal/Config.hs b/src/Database/Relational/Query/Internal/Config.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/Config.hs +++ /dev/null @@ -1,74 +0,0 @@ --- | --- Module : Database.Relational.Query.Internal.Config --- Copyright : 2017 Kei Hibino --- License : BSD3 --- --- Maintainer : ex8k.hibino@gmail.com --- Stability : experimental --- Portability : unknown --- --- This module defines configuration datatype used in query products. -module Database.Relational.Query.Internal.Config ( - NameConfig (..), - ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), - Config ( productUnitSupport - , chunksInsertSize - , schemaNameMode - , normalizedTableName - , verboseAsCompilerWarning - , identifierQuotation - , nameConfig), - defaultConfig, - ) where - -import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) -import qualified Database.Record.TH as RecordTH - - --- | 'NameConfig' type to customize names of expanded templates. -data NameConfig = - NameConfig - { recordConfig :: RecordTH.NameConfig - , relationVarName :: String -> String -> VarName - } - -instance Show NameConfig where - show = const "" - --- | Unit of product is supported or not. -data ProductUnitSupport = PUSupported | PUNotSupported deriving Show - --- | Schema name qualify mode in SQL string. -data SchemaNameMode - = SchemaQualified -- ^ Schema qualified table name in SQL string - | SchemaNotQualified -- ^ Not qualified table name in SQL string - deriving (Eq, Show) - --- | Configuration for quotation of identifiers of SQL. -data IdentifierQuotation = NoQuotation | Quotation Char deriving Show - --- | Configuration type. -data Config = - Config - { productUnitSupport :: !ProductUnitSupport - , chunksInsertSize :: !Int - , schemaNameMode :: !SchemaNameMode - , normalizedTableName :: !Bool - , verboseAsCompilerWarning :: !Bool - , identifierQuotation :: !IdentifierQuotation - , nameConfig :: !NameConfig - } deriving Show - --- | Default configuration. -defaultConfig :: Config -defaultConfig = - Config { productUnitSupport = PUSupported - , chunksInsertSize = 256 - , schemaNameMode = SchemaQualified - , normalizedTableName = True - , verboseAsCompilerWarning = False - , identifierQuotation = NoQuotation - , nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig - , relationVarName = const varCamelcaseName - } - } diff --git a/src/Database/Relational/Query/Internal/ContextType.hs b/src/Database/Relational/Query/Internal/ContextType.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/ContextType.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} - --- | --- Module : Database.Relational.Query.Internal.ContextType --- Copyright : 2013-2017 Kei Hibino --- License : BSD3 --- --- Maintainer : ex8k.hibino@gmail.com --- Stability : experimental --- Portability : unknown --- --- This module defines query context tag types. -module Database.Relational.Query.Internal.ContextType ( - Flat, Aggregated, Exists, OverWindow, - - Set, SetList, Power, - ) where - --- | Type tag for flat (not-aggregated) query -data Flat - --- | Type tag for aggregated query -data Aggregated - --- | Type tag for exists predicate -data Exists - --- | Type tag for window function building -data OverWindow - - --- | Type tag for normal aggregatings set -data Set - --- | Type tag for aggregatings GROUPING SETS -data SetList - --- | Type tag for aggregatings power set -data Power diff --git a/src/Database/Relational/Query/Internal/GroupingSQL.hs b/src/Database/Relational/Query/Internal/GroupingSQL.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/GroupingSQL.hs +++ /dev/null @@ -1,119 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Internal/Product.hs b/src/Database/Relational/Query/Internal/Product.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/Product.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- 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) diff --git a/src/Database/Relational/Query/Internal/SQL.hs b/src/Database/Relational/Query/Internal/SQL.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/SQL.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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 (|*|) diff --git a/src/Database/Relational/Query/Internal/Sub.hs b/src/Database/Relational/Query/Internal/Sub.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/Sub.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# 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)] diff --git a/src/Database/Relational/Query/Internal/UntypedTable.hs b/src/Database/Relational/Query/Internal/UntypedTable.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Internal/UntypedTable.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Monad/Aggregate.hs b/src/Database/Relational/Query/Monad/Aggregate.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Aggregate.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# 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` diff --git a/src/Database/Relational/Query/Monad/Assign.hs b/src/Database/Relational/Query/Monad/Assign.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Assign.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/BaseType.hs b/src/Database/Relational/Query/Monad/BaseType.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/BaseType.hs +++ /dev/null @@ -1,95 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Monad/Class.hs b/src/Database/Relational/Query/Monad/Class.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Class.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Register.hs b/src/Database/Relational/Query/Monad/Register.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Register.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Monad/Restrict.hs b/src/Database/Relational/Query/Monad/Restrict.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Restrict.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Simple.hs b/src/Database/Relational/Query/Monad/Simple.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Simple.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Aggregating.hs b/src/Database/Relational/Query/Monad/Trans/Aggregating.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Aggregating.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Assigning.hs b/src/Database/Relational/Query/Monad/Trans/Assigning.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Assigning.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Config.hs b/src/Database/Relational/Query/Monad/Trans/Config.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Config.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Join.hs b/src/Database/Relational/Query/Monad/Trans/Join.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Join.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# 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) diff --git a/src/Database/Relational/Query/Monad/Trans/JoinState.hs b/src/Database/Relational/Query/Monad/Trans/JoinState.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/JoinState.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Ordering.hs b/src/Database/Relational/Query/Monad/Trans/Ordering.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Ordering.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Qualify.hs b/src/Database/Relational/Query/Monad/Trans/Qualify.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Qualify.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Trans/Restricting.hs b/src/Database/Relational/Query/Monad/Trans/Restricting.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Trans/Restricting.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Monad/Type.hs b/src/Database/Relational/Query/Monad/Type.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Type.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | --- 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) diff --git a/src/Database/Relational/Query/Monad/Unique.hs b/src/Database/Relational/Query/Monad/Unique.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Monad/Unique.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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 [] diff --git a/src/Database/Relational/Query/Pi.hs b/src/Database/Relational/Query/Pi.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Pi.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/Pi/Unsafe.hs b/src/Database/Relational/Query/Pi/Unsafe.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Pi/Unsafe.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Projectable.hs b/src/Database/Relational/Query/Projectable.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Projectable.hs +++ /dev/null @@ -1,551 +0,0 @@ -{-# 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 >< diff --git a/src/Database/Relational/Query/ProjectableClass.hs b/src/Database/Relational/Query/ProjectableClass.hs deleted file mode 100644 --- a/src/Database/Relational/Query/ProjectableClass.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/ProjectableExtended.hs b/src/Database/Relational/Query/ProjectableExtended.hs deleted file mode 100644 --- a/src/Database/Relational/Query/ProjectableExtended.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# 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 >?< diff --git a/src/Database/Relational/Query/Projection.hs b/src/Database/Relational/Query/Projection.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Projection.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Pure.hs b/src/Database/Relational/Query/Pure.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Pure.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Relation.hs b/src/Database/Relational/Query/Relation.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Relation.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# 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' diff --git a/src/Database/Relational/Query/SQL.hs b/src/Database/Relational/Query/SQL.hs deleted file mode 100644 --- a/src/Database/Relational/Query/SQL.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/Scalar.hs b/src/Database/Relational/Query/Scalar.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Scalar.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# 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) |] diff --git a/src/Database/Relational/Query/Sub.hs b/src/Database/Relational/Query/Sub.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Sub.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# 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 diff --git a/src/Database/Relational/Query/TH.hs b/src/Database/Relational/Query/TH.hs deleted file mode 100644 --- a/src/Database/Relational/Query/TH.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# 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] diff --git a/src/Database/Relational/Query/Table.hs b/src/Database/Relational/Query/Table.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Table.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Query/TupleInstances.hs b/src/Database/Relational/Query/TupleInstances.hs deleted file mode 100644 --- a/src/Database/Relational/Query/TupleInstances.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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. diff --git a/src/Database/Relational/Query/Type.hs b/src/Database/Relational/Query/Type.hs deleted file mode 100644 --- a/src/Database/Relational/Query/Type.hs +++ /dev/null @@ -1,353 +0,0 @@ --- | --- 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 diff --git a/src/Database/Relational/Record.hs b/src/Database/Relational/Record.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Record.hs @@ -0,0 +1,203 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Record +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines interfaces of projected record type. +module Database.Relational.Record ( + -- * Record data structure and interface + Record, + + width, + columns, + untype, + + unsafeFromSqlTerms, + unsafeFromQualifiedSubQuery, + unsafeFromScalarSubQuery, + unsafeFromTable, + + unsafeStringSql, + + -- * Projections + pi, piMaybe, piMaybe', + wpi, + + flattenMaybe, just, + + unsafeToAggregated, unsafeToFlat, unsafeChangeContext, + unsafeStringSqlNotNullMaybe, + + -- * List of Record + RecordList, list, unsafeListFromSubQuery, + unsafeStringSqlList + ) where + +import Prelude hiding (pi) +import Data.Functor.ProductIsomorphic + (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), + ProductIsoEmpty, pureE, peRight, peLeft, ) + +import qualified Language.SQL.Keyword as SQL + +import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint, PersistableWidth, persistableWidth) +import Database.Record.Persistable (PersistableRecordWidth) +import qualified Database.Record.KeyConstraint as KeyConstraint + +import Database.Relational.Internal.ContextType (Aggregated, Flat) +import Database.Relational.Internal.String (StringSQL, listStringSQL, rowStringSQL) +import Database.Relational.SqlSyntax + (SubQuery, Qualified, Tuple, Record, + recordRawColumns, tupleFromJoinedSubQuery,) +import qualified Database.Relational.SqlSyntax as Syntax + +import Database.Relational.Table (Table) +import qualified Database.Relational.Table as Table +import Database.Relational.Pi (Pi) +import qualified Database.Relational.Pi.Unsafe as UnsafePi + + +-- | Unsafely get SQL term from 'Record'. +unsafeStringSql :: Record c r -> StringSQL +unsafeStringSql = rowStringSQL . recordRawColumns + +-- | Get column SQL string list of record. +columns :: Record c r -- ^ Source 'Record' + -> [StringSQL] -- ^ Result SQL string list +columns = recordRawColumns + +-- | Width of 'Record'. +width :: Record c r -> Int +width = Syntax.recordWidth + +-- | Get untyped tuple. +untype :: Record c r -> Tuple +untype = Syntax.untypeRecord + + +-- | Unsafely generate 'Record' from qualified (joined) sub-query. +unsafeFromQualifiedSubQuery :: Qualified SubQuery -> Record c t +unsafeFromQualifiedSubQuery = Syntax.record . tupleFromJoinedSubQuery + +-- | Unsafely generate 'Record' from scalar sub-query. +unsafeFromScalarSubQuery :: SubQuery -> Record c t +unsafeFromScalarSubQuery = Syntax.typeFromScalarSubQuery + +-- | Unsafely generate unqualified 'Record' from 'Table'. +unsafeFromTable :: Table r + -> Record c r +unsafeFromTable = Syntax.typeFromRawColumns . Table.columns + +-- | Unsafely generate 'Record' from SQL expression strings. +unsafeFromSqlTerms :: [StringSQL] -> Record c t +unsafeFromSqlTerms = Syntax.typeFromRawColumns + + +-- | Unsafely trace projection path. +unsafeProject :: PersistableRecordWidth a -> Record c a' -> Pi a b -> Record c b' +unsafeProject w p pi' = + Syntax.typeFromRawColumns + . (UnsafePi.pi w pi') + . columns $ p + +-- | Trace projection path to get narrower 'Record'. +wpi :: PersistableRecordWidth a + -> Record c a -- ^ Source 'Record' + -> Pi a b -- ^ Projection path + -> Record c b -- ^ Narrower 'Record' +wpi = unsafeProject + +-- | Trace projection path to get narrower 'Record'. +pi :: PersistableWidth a + => Record c a -- ^ Source 'Record' + -> Pi a b -- ^ Record path + -> Record c b -- ^ Narrower 'Record' +pi = unsafeProject persistableWidth + +-- | Trace projection path to get narrower 'Record'. From 'Maybe' type to 'Maybe' type. +piMaybe :: PersistableWidth a + => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type + -> Pi a b -- ^ Projection path + -> Record c (Maybe b) -- ^ Narrower 'Record'. 'Maybe' type result +piMaybe = unsafeProject persistableWidth + +-- | Trace projection path to get narrower 'Record'. From 'Maybe' type to 'Maybe' type. +-- Leaf type of projection path is 'Maybe'. +piMaybe' :: PersistableWidth a + => Record c (Maybe a) -- ^ Source 'Record'. 'Maybe' type + -> Pi a (Maybe b) -- ^ Projection path. 'Maybe' type leaf + -> Record c (Maybe b) -- ^ Narrower 'Record'. 'Maybe' type result +piMaybe' = unsafeProject persistableWidth + +unsafeCast :: Record c r -> Record c r' +unsafeCast = Syntax.record . Syntax.untypeRecord + +-- | Composite nested 'Maybe' on record phantom type. +flattenMaybe :: Record c (Maybe (Maybe a)) -> Record c (Maybe a) +flattenMaybe = unsafeCast + +-- | Cast into 'Maybe' on record phantom type. +just :: Record c r -> Record c (Maybe r) +just = unsafeCast + +-- | Unsafely cast context type tag. +unsafeChangeContext :: Record c r -> Record c' r +unsafeChangeContext = Syntax.record . Syntax.untypeRecord + +-- | Unsafely lift to aggregated context. +unsafeToAggregated :: Record Flat r -> Record Aggregated r +unsafeToAggregated = unsafeChangeContext + +-- | Unsafely down to flat context. +unsafeToFlat :: Record Aggregated r -> Record Flat r +unsafeToFlat = unsafeChangeContext + +notNullMaybeConstraint :: HasColumnConstraint NotNull r => Record c (Maybe r) -> NotNullColumnConstraint r +notNullMaybeConstraint = const KeyConstraint.columnConstraint + +-- | Unsafely get SQL string expression of not null key record. +unsafeStringSqlNotNullMaybe :: HasColumnConstraint NotNull r => Record c (Maybe r) -> StringSQL +unsafeStringSqlNotNullMaybe p = (!! KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p + +pempty :: Record c () +pempty = Syntax.record [] + +-- | Map 'Record' which result type is record. +instance ProductIsoFunctor (Record c) where + _ |$| p = unsafeCast p + +-- | Compose 'Record' using applicative style. +instance ProductIsoApplicative (Record c) where + pureP _ = unsafeCast pempty + pf |*| pa = Syntax.record $ Syntax.untypeRecord pf ++ Syntax.untypeRecord pa + +instance ProductIsoEmpty (Record c) () where + pureE = pureP () + peRight = unsafeCast + peLeft = unsafeCast + +-- | Projected record list type for row list. +data RecordList p t = List [p t] + | Sub SubQuery + +-- | Make projected record list from 'Record' list. +list :: [p t] -> RecordList p t +list = List + +-- | Make projected record list from 'SubQuery'. +unsafeListFromSubQuery :: SubQuery -> RecordList p t +unsafeListFromSubQuery = Sub + +-- | Map record show operatoions and concatinate to single SQL expression. +unsafeStringSqlList :: (p t -> StringSQL) -> RecordList p t -> StringSQL +unsafeStringSqlList sf = d where + d (List ps) = listStringSQL $ map sf ps + d (Sub sub) = SQL.paren $ Syntax.showSQL sub diff --git a/src/Database/Relational/Relation.hs b/src/Database/Relational/Relation.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Relation.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.Relational.Relation +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module integrate monadic operations to compose complex queries +-- with re-usable Relation type. +module Database.Relational.Relation ( + -- * Relation type + table, derivedRelation, tableOf, + relation, relation', + aggregateRelation, aggregateRelation', + + UniqueRelation, + unsafeUnique, unUnique, + + uniqueRelation', aggregatedUnique, + + -- * Query using relation + query, queryMaybe, queryList, queryList', queryScalar, queryScalar', + uniqueQuery', uniqueQueryMaybe', + ) where + +import Control.Applicative ((<$>)) + +import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Relational.SqlSyntax (NodeAttr(Just', Maybe), Record, ) + +import Database.Relational.Monad.BaseType + (ConfigureQuery, qualifyQuery, + Relation, unsafeTypeRelation, untypeRelation, relationWidth) +import Database.Relational.Monad.Class + (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), ) +import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery) +import qualified Database.Relational.Monad.Simple as Simple +import Database.Relational.Monad.Aggregate (QueryAggregate, AggregatedQuery) +import qualified Database.Relational.Monad.Aggregate as Aggregate +import Database.Relational.Monad.Unique (QueryUnique, unsafeUniqueSubQuery) +import qualified Database.Relational.Monad.Unique as Unique +import Database.Relational.Table (Table, TableDerivable, derivedTable) +import qualified Database.Relational.Table as Table +import Database.Relational.Scalar (ScalarDegree) +import Database.Relational.Pi (Pi) +import Database.Relational.Record (RecordList) +import qualified Database.Relational.Record as Record +import Database.Relational.Projectable + (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, ) + + +-- | Simple 'Relation' from 'Table'. +table :: Table r -> Relation () r +table = unsafeTypeRelation . return . Table.toSubQuery + +-- | Inferred 'Relation'. +derivedRelation :: TableDerivable r => Relation () r +derivedRelation = table derivedTable + +-- | Interface to derive 'Table' type object. +tableOf :: TableDerivable r => Relation () r -> Table r +tableOf = const derivedTable + +placeHoldersFromRelation :: Relation p r -> PlaceHolders p +placeHoldersFromRelation = const unsafePlaceHolders + +-- | Join sub-query. Query result is not 'Maybe'. +query :: (MonadQualify ConfigureQuery m, MonadQuery m) + => Relation () r + -> m (Record Flat r) +query = fmap snd . query' + +-- | Join sub-query. Query result is 'Maybe'. +-- The combinations of 'query' and 'queryMaybe' express +-- inner joins, left outer joins, right outer joins, and full outer joins. +-- Here is an example of a right outer join: +-- +-- @ +-- outerJoin = relation $ do +-- e <- queryMaybe employee +-- d <- query department +-- on $ e ?! E.deptId' .=. just (d ! D.deptId') +-- return $ (,) |$| e |*| d +-- @ +queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) + => Relation () r + -> m (Record Flat (Maybe r)) +queryMaybe = fmap snd . queryMaybe' + +queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (RecordList (Record c) r) +queryList0 = liftQualify + . fmap Record.unsafeListFromSubQuery + . untypeRelation + +-- | List sub-query, for /IN/ and /EXIST/ with place-holder parameter 'p'. +queryList' :: MonadQualify ConfigureQuery m + => Relation p r + -> m (PlaceHolders p, RecordList (Record c) r) +queryList' rel = do + ql <- queryList0 rel + return (placeHoldersFromRelation rel, ql) + +-- | List sub-query, for /IN/ and /EXIST/. +queryList :: MonadQualify ConfigureQuery m + => Relation () r + -> m (RecordList (Record c) r) +queryList = queryList0 + +addUnitPH :: Functor f => f t -> f (PlaceHolders (), t) +addUnitPH = ((,) unitPlaceHolder <$>) + +-- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'. +relation' :: SimpleQuery p r -> Relation p r +relation' = unsafeTypeRelation . Simple.toSubQuery + +-- | Finalize 'QuerySimple' monad and generate 'Relation'. +relation :: QuerySimple (Record Flat r) -> Relation () r +relation = relation' . addUnitPH + +-- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'. +aggregateRelation' :: AggregatedQuery p r -> Relation p r +aggregateRelation' = unsafeTypeRelation . Aggregate.toSubQuery + +-- | Finalize 'QueryAggregate' monad and geneate 'Relation'. +aggregateRelation :: QueryAggregate (Record Aggregated r) -> Relation () r +aggregateRelation = aggregateRelation' . addUnitPH + + +-- | Unique relation type to compose scalar queries. +newtype UniqueRelation p c r = Unique (Relation p r) + +-- | Unsafely specify unique relation. +unsafeUnique :: Relation p r -> UniqueRelation p c r +unsafeUnique = Unique + +-- | Discard unique attribute. +unUnique :: UniqueRelation p c r -> Relation p r +unUnique (Unique r) = r + +-- | Basic monadic join operation using 'MonadQuery'. +uniqueQueryWithAttr :: NodeAttr + -> UniqueRelation p c r + -> QueryUnique (PlaceHolders p, Record c r) +uniqueQueryWithAttr attr = unsafeAddPlaceHolders . run where + run rel = do + q <- liftQualify $ do + sq <- untypeRelation (unUnique rel) + qualifyQuery sq + Record.unsafeChangeContext <$> unsafeUniqueSubQuery attr q + +-- | Join unique sub-query with place-holder parameter 'p'. +uniqueQuery' :: UniqueRelation p c r + -> QueryUnique (PlaceHolders p, Record c r) +uniqueQuery' = uniqueQueryWithAttr Just' + +-- | Join unique sub-query with place-holder parameter 'p'. Query result is 'Maybe'. +uniqueQueryMaybe' :: UniqueRelation p c r + -> QueryUnique (PlaceHolders p, Record c (Maybe r)) +uniqueQueryMaybe' pr = do + (ph, pj) <- uniqueQueryWithAttr Maybe pr + return (ph, Record.just pj) + +-- | Finalize 'QueryUnique' monad and generate 'UniqueRelation'. +uniqueRelation' :: QueryUnique (PlaceHolders p, Record c r) -> UniqueRelation p c r +uniqueRelation' = unsafeUnique . unsafeTypeRelation . Unique.toSubQuery + +-- | Aggregated 'UniqueRelation'. +aggregatedUnique :: Relation ph r + -> Pi r a + -> (Record Flat a -> Record Aggregated b) + -> UniqueRelation ph Flat b +aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ do + (ph, a) <- query' rel + return (ph, ag $ Record.wpi (relationWidth rel) a k) + +-- | Scalar sub-query with place-holder parameter 'p'. +queryScalar' :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => UniqueRelation p c r + -> m (PlaceHolders p, Record c (Maybe r)) +queryScalar' ur = + unsafeAddPlaceHolders . liftQualify $ + Record.unsafeFromScalarSubQuery <$> untypeRelation (unUnique ur) + +-- | Scalar sub-query. +queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) + => UniqueRelation () c r + -> m (Record c (Maybe r)) +queryScalar = fmap snd . queryScalar' diff --git a/src/Database/Relational/Scalar.hs b/src/Database/Relational/Scalar.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Scalar.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- Module : Database.Relational.Scalar +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines type classes and templates for scalar queries. +module Database.Relational.Scalar ( + -- * Single degree constraint + ScalarDegree, defineScalarDegree + ) where + +import Language.Haskell.TH (Q, TypeQ, Dec) + +import Database.Record (PersistableWidth) + + +-- | Constraint which represents scalar degree. +class PersistableWidth ct => ScalarDegree ct + +instance ScalarDegree ct => ScalarDegree (Maybe ct) + +-- | 'ScalarDegree' instance templates. +defineScalarDegree :: TypeQ -> Q [Dec] +defineScalarDegree typeCon = do + [d| instance ScalarDegree $(typeCon) |] diff --git a/src/Database/Relational/Set.hs b/src/Database/Relational/Set.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Set.hs @@ -0,0 +1,213 @@ +-- | +-- Module : Database.Relational.Set +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines set operations on monadic Relation operations. +module Database.Relational.Set ( + -- * Direct style join + JoinRestriction, + inner', left', right', full', + inner, left, right, full, + on', + + -- * Relation append + union, except, intersect, + unionAll, exceptAll, intersectAll, + + union', except', intersect', + unionAll', exceptAll', intersectAll', + ) where + +import Data.Functor.ProductIsomorphic ((|$|), (|*|)) + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax + (Duplication (Distinct, All), SubQuery, Predicate, Record, ) +import qualified Database.Relational.SqlSyntax as Syntax + +import Database.Relational.Monad.BaseType + (Relation, unsafeTypeRelation, untypeRelation, ) +import Database.Relational.Monad.Class (MonadQuery (query', queryMaybe'), on) +import Database.Relational.Monad.Simple (QuerySimple) +import Database.Relational.Projectable (PlaceHolders) +import Database.Relational.Relation (relation', relation, query, queryMaybe, ) + + +-- | Restriction predicate function type for direct style join operator, +-- used on predicates of direct join style as follows. +-- +-- @ +-- do xy <- query $ +-- relX `inner` relY `on'` [ \x y -> ... ] -- this lambda form has JoinRestriction type +-- ... +-- @ +type JoinRestriction a b = Record Flat a -> Record Flat b -> Predicate Flat + +-- | Basic direct join operation with place-holder parameters. +join' :: (qa -> QuerySimple (PlaceHolders pa, Record Flat a)) + -> (qb -> QuerySimple (PlaceHolders pb, Record Flat b)) + -> qa + -> qb + -> [JoinRestriction a b] + -> Relation (pa, pb) (a, b) +join' qL qR r0 r1 rs = relation' $ do + (ph0, pj0) <- qL r0 + (ph1, pj1) <- qR r1 + sequence_ [ on $ f pj0 pj1 | f <- rs ] + return ((,) |$| ph0 |*| ph1, (,) |$| pj0 |*| pj1) + +-- | Direct inner join with place-holder parameters. +inner' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction a b] -- ^ Join restrictions + -> Relation (pa, pb) (a, b) -- ^ Result joined relation +inner' = join' query' query' + +-- | Direct left outer join with place-holder parameters. +left' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions + -> Relation (pa, pb) (a, Maybe b) -- ^ Result joined relation +left' = join' query' queryMaybe' + +-- | Direct right outer join with place-holder parameters. +right' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions + -> Relation (pa, pb)(Maybe a, b) -- ^ Result joined relation +right' = join' queryMaybe' query' + +-- | Direct full outer join with place-holder parameters. +full' :: Relation pa a -- ^ Left query to join + -> Relation pb b -- ^ Right query to join + -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions + -> Relation (pa, pb) (Maybe a, Maybe b) -- ^ Result joined relation +full' = join' queryMaybe' queryMaybe' + +-- | Basic direct join operation. +join_ :: (qa -> QuerySimple (Record Flat a)) + -> (qb -> QuerySimple (Record Flat b)) + -> qa + -> qb + -> [JoinRestriction a b] + -> Relation () (a, b) +join_ qL qR r0 r1 rs = relation $ do + pj0 <- qL r0 + pj1 <- qR r1 + sequence_ [ on $ f pj0 pj1 | f <- rs ] + return $ (,) |$| pj0 |*| pj1 + +-- | Direct inner join. +inner :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction a b] -- ^ Join restrictions + -> Relation () (a, b) -- ^ Result joined relation +inner = join_ query query + +-- | Direct left outer join. +left :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction a (Maybe b)] -- ^ Join restrictions + -> Relation () (a, Maybe b) -- ^ Result joined relation +left = join_ query queryMaybe + +-- | Direct right outer join. +right :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction (Maybe a) b] -- ^ Join restrictions + -> Relation () (Maybe a, b) -- ^ Result joined relation +right = join_ queryMaybe query + +-- | Direct full outer join. +full :: Relation () a -- ^ Left query to join + -> Relation () b -- ^ Right query to join + -> [JoinRestriction (Maybe a) (Maybe b)] -- ^ Join restrictions + -> Relation () (Maybe a, Maybe b) -- ^ Result joined relation +full = join_ queryMaybe queryMaybe + +-- | Apply restriction for direct join style. +on' :: ([JoinRestriction a b] -> Relation pc (a, b)) + -> [JoinRestriction a b] + -> Relation pc (a, b) +on' = ($) + +infixl 8 `inner'`, `left'`, `right'`, `full'`, `inner`, `left`, `right`, `full`, `on'` + +unsafeLiftAppend :: (SubQuery -> SubQuery -> SubQuery) + -> Relation p a + -> Relation q a + -> Relation r a +unsafeLiftAppend op a0 a1 = unsafeTypeRelation $ do + s0 <- untypeRelation a0 + s1 <- untypeRelation a1 + return $ s0 `op` s1 + +liftAppend :: (SubQuery -> SubQuery -> SubQuery) + -> Relation () a + -> Relation () a + -> Relation () a +liftAppend = unsafeLiftAppend + +-- | Union of two relations. +union :: Relation () a -> Relation () a -> Relation () a +union = liftAppend $ Syntax.union Distinct + +-- | Union of two relations. Not distinct. +unionAll :: Relation () a -> Relation () a -> Relation () a +unionAll = liftAppend $ Syntax.union All + +-- | Subtraction of two relations. +except :: Relation () a -> Relation () a -> Relation () a +except = liftAppend $ Syntax.except Distinct + +-- | Subtraction of two relations. Not distinct. +exceptAll :: Relation () a -> Relation () a -> Relation () a +exceptAll = liftAppend $ Syntax.except All + +-- | Intersection of two relations. +intersect :: Relation () a -> Relation () a -> Relation () a +intersect = liftAppend $ Syntax.intersect Distinct + +-- | Intersection of two relations. Not distinct. +intersectAll :: Relation () a -> Relation () a -> Relation () a +intersectAll = liftAppend $ Syntax.intersect All + +liftAppend' :: (SubQuery -> SubQuery -> SubQuery) + -> Relation p a + -> Relation q a + -> Relation (p, q) a +liftAppend' = unsafeLiftAppend + +-- | Union of two relations with place-holder parameters. +union' :: Relation p a -> Relation q a -> Relation (p, q) a +union' = liftAppend' $ Syntax.union Distinct + +-- | Union of two relations with place-holder parameters. Not distinct. +unionAll' :: Relation p a -> Relation q a -> Relation (p, q) a +unionAll' = liftAppend' $ Syntax.union All + +-- | Subtraction of two relations with place-holder parameters. +except' :: Relation p a -> Relation q a -> Relation (p, q) a +except' = liftAppend' $ Syntax.except Distinct + +-- | Subtraction of two relations with place-holder parameters. Not distinct. +exceptAll' :: Relation p a -> Relation q a -> Relation (p, q) a +exceptAll' = liftAppend' $ Syntax.except All + +-- | Intersection of two relations with place-holder parameters. +intersect' :: Relation p a -> Relation q a -> Relation (p, q) a +intersect' = liftAppend' $ Syntax.intersect Distinct + +-- | Intersection of two relations with place-holder parameters. Not distinct. +intersectAll' :: Relation p a -> Relation q a -> Relation (p, q) a +intersectAll' = liftAppend' $ Syntax.intersect All + +infixl 7 `union`, `except`, `unionAll`, `exceptAll` +infixl 8 `intersect`, `intersectAll` +infixl 7 `union'`, `except'`, `unionAll'`, `exceptAll'` +infixl 8 `intersect'`, `intersectAll'` diff --git a/src/Database/Relational/SimpleSql.hs b/src/Database/Relational/SimpleSql.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SimpleSql.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Relational.SimpleSql +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines functions to generate simple SQL strings. +module Database.Relational.SimpleSql ( + -- * Query suffix + QuerySuffix, showsQuerySuffix, + + -- * Update SQL + updatePrefixSQL, + updateOtherThanKeySQL, + + -- * Insert SQL + insertPrefixSQL, + + -- * Delete SQL + deletePrefixSQL + ) where + +import Data.Array (listArray, (!)) +import Data.Monoid (mconcat, (<>)) + +import Language.SQL.Keyword (Keyword(..), (.=.), (|*|)) +import qualified Language.SQL.Keyword as SQL +import Database.Record.ToSql (untypedUpdateValuesIndex) + +import Database.Relational.Internal.String + (StringSQL, stringSQL, showStringSQL, rowConsStringSQL, ) + +import Database.Relational.Pi (Pi) +import qualified Database.Relational.Pi.Unsafe as UnsafePi +import Database.Relational.Table (Table, name, columns, recordWidth) +import qualified Database.Relational.Record as Record + + +-- | Type for query suffix words +type QuerySuffix = [Keyword] + +-- | Expand query suffix words +showsQuerySuffix :: QuerySuffix -> StringSQL +showsQuerySuffix = mconcat + +-- | Generate prefix string of update SQL. +updatePrefixSQL :: Table r -> StringSQL +updatePrefixSQL table = UPDATE <> stringSQL (name table) + +-- | Generate update SQL by specified key and table. +-- Columns name list of table are also required. +updateSQL' :: String -- ^ Table name + -> [StringSQL] -- ^ Column name list to update + -> [StringSQL] -- ^ Key column name list + -> String -- ^ Result SQL +updateSQL' table cols key = + showStringSQL $ mconcat + [UPDATE, stringSQL table, SET, SQL.fold (|*|) updAssigns, + WHERE, SQL.fold SQL.and keyAssigns] + where + assigns cs = [ c .=. "?" | c <- cs ] + updAssigns = assigns cols + keyAssigns = assigns key + +-- | Generate update SQL by specified key and table. +-- Columns name list of table are also required. +updateOtherThanKeySQL' :: String -- ^ Table name + -> [StringSQL] -- ^ Column name list + -> [Int] -- ^ Key column indexes + -> String -- ^ Result SQL +updateOtherThanKeySQL' table cols ixs = + updateSQL' table updColumns keyColumns + where + width' = length cols + cols' = listArray (0, width' -1) cols + otherThanKey = untypedUpdateValuesIndex ixs width' + columns' is = [ cols' ! i | i <- is ] + updColumns = columns' otherThanKey + keyColumns = columns' ixs + +-- | Generate update SQL specified by single key. +updateOtherThanKeySQL :: Table r -- ^ Table metadata + -> Pi r p -- ^ Key columns + -> String -- ^ Result SQL +updateOtherThanKeySQL tbl key = + updateOtherThanKeySQL' (name tbl) (columns tbl) (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 = Record.columns . Record.wpi (recordWidth table) (Record.unsafeFromTable table) $ pi' + +-- | Generate all column delete SQL by specified table. Untyped table version. +deletePrefixSQL' :: String -> StringSQL +deletePrefixSQL' table = DELETE <> FROM <> stringSQL table + +-- | Generate all column delete SQL by specified table. +deletePrefixSQL :: Table r -- ^ Table metadata + -> StringSQL -- ^ Result SQL +deletePrefixSQL = deletePrefixSQL' . name diff --git a/src/Database/Relational/SqlSyntax.hs b/src/Database/Relational/SqlSyntax.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax.hs @@ -0,0 +1,25 @@ +-- | +-- Module : Database.Relational.SqlSyntax +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module is integrated module of sql-syntax. +module Database.Relational.SqlSyntax ( + module Database.Relational.SqlSyntax.Types, + module Database.Relational.SqlSyntax.Join, + module Database.Relational.SqlSyntax.Aggregate, + module Database.Relational.SqlSyntax.Query, + module Database.Relational.SqlSyntax.Fold, + module Database.Relational.SqlSyntax.Updates, + ) where + +import Database.Relational.SqlSyntax.Types +import Database.Relational.SqlSyntax.Join (growProduct, restrictProduct, ) +import Database.Relational.SqlSyntax.Aggregate +import Database.Relational.SqlSyntax.Query +import Database.Relational.SqlSyntax.Fold +import Database.Relational.SqlSyntax.Updates diff --git a/src/Database/Relational/SqlSyntax/Aggregate.hs b/src/Database/Relational/SqlSyntax/Aggregate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax/Aggregate.hs @@ -0,0 +1,94 @@ +-- | +-- Module : Database.Relational.SqlSyntax.Aggregate +-- 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.SqlSyntax.Aggregate ( + aggregateColumnRef, + aggregatePowerKey, aggregateGroupingSet, + aggregateRollup, aggregateCube, aggregateSets, + + composeGroupBy, composePartitionBy, + + aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey, + ) where + +import Data.Monoid (Monoid (..), (<>)) + +import Language.SQL.Keyword (Keyword(..), (|*|)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Internal.String (StringSQL) +import Database.Relational.SqlSyntax.Types + (AggregateBitKey (..), AggregateSet (..), AggregateElem (..), + AggregateColumnRef, AggregateKey (..), ) + + +-- | Single term aggregation element. +aggregateColumnRef :: AggregateColumnRef -> AggregateElem +aggregateColumnRef = ColumnRef + +-- | Key of aggregation power set. +aggregatePowerKey :: [AggregateColumnRef] -> AggregateBitKey +aggregatePowerKey = AggregateBitKey + +-- | Single grouping set. +aggregateGroupingSet :: [AggregateElem] -> AggregateSet +aggregateGroupingSet = AggregateSet + +-- | Rollup aggregation element. +aggregateRollup :: [AggregateBitKey] -> AggregateElem +aggregateRollup = Rollup + +-- | Cube aggregation element. +aggregateCube :: [AggregateBitKey] -> AggregateElem +aggregateCube = Cube + +-- | Grouping sets aggregation. +aggregateSets :: [AggregateSet] -> AggregateElem +aggregateSets = GroupingSets + +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 record from 'AggregateKey'. +aggregateKeyRecord :: AggregateKey a -> a +aggregateKeyRecord (AggregateKey (p, _c)) = p + +-- | Extract untyped term from 'AggregateKey'. +aggregateKeyElement :: AggregateKey a -> AggregateElem +aggregateKeyElement (AggregateKey (_p, c)) = c + +-- | Unsafely bind typed-record and untyped-term into 'AggregateKey'. +unsafeAggregateKey :: (a, AggregateElem) -> AggregateKey a +unsafeAggregateKey = AggregateKey diff --git a/src/Database/Relational/SqlSyntax/Fold.hs b/src/Database/Relational/SqlSyntax/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax/Fold.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Relational.SqlSyntax.Fold +-- 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.SqlSyntax.Fold ( + -- * Sub-query + showSQL, toSQL, unitSQL, width, + + -- * Qualified Sub-query + queryWidth, + + -- * Sub-query columns + column, + + -- * Tuple and Record + tupleFromJoinedSubQuery, + + recordRawColumns, + + -- * Query restriction + composeWhere, composeHaving + ) where + +import Control.Applicative ((<$>), pure) +import Data.Monoid (mempty, (<>), mconcat) +import Data.Traversable (traverse) + +import Language.SQL.Keyword (Keyword(..), (|*|)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Relational.Internal.Config + (Config (productUnitSupport), ProductUnitSupport (PUSupported, PUNotSupported), ) +import Database.Relational.Internal.UntypedTable ((!)) +import qualified Database.Relational.Internal.UntypedTable as UntypedTable +import Database.Relational.Internal.String + (StringSQL, stringSQL, rowStringSQL, showStringSQL, boolSQL, ) +import Database.Relational.SqlSyntax.Query (composeOrderBy, ) +import Database.Relational.SqlSyntax.Aggregate (composeGroupBy, ) +import Database.Relational.SqlSyntax.Types + (SubQuery (..), Record, Tuple, Predicate, + Column (..), CaseClause(..), WhenClauses (..), + NodeAttr (Just', Maybe), ProductTree (Leaf, Join), JoinProduct, + Duplication (..), SetOp (..), BinOp (..), Qualifier (..), Qualified (..), ) +import qualified Database.Relational.SqlSyntax.Types as Syntax + + +-- | Compose duplication attribute string. +showsDuplication :: Duplication -> StringSQL +showsDuplication = dup where + dup All = ALL + dup Distinct = DISTINCT + +showsSetOp' :: SetOp -> StringSQL +showsSetOp' = d where + d Union = UNION + d Except = EXCEPT + d Intersect = INTERSECT + +showsSetOp :: SetOp -> Duplication -> StringSQL +showsSetOp op dup0 = showsSetOp' op <> mayDup dup0 where + mayDup dup@All = showsDuplication dup + mayDup Distinct = mempty + +-- | Alias string from qualifier +showQualifier :: Qualifier -> StringSQL +showQualifier (Qualifier i) = stringSQL $ 'T' : show i + +-- | Binary operator to qualify. +(<.>) :: Qualifier -> StringSQL -> StringSQL +i <.> n = showQualifier i SQL.<.> n + +columnN :: Int -> StringSQL +columnN i = stringSQL $ 'f' : show i + +asColumnN :: StringSQL -> Int -> StringSQL +c `asColumnN` n =c `SQL.as` columnN n + +-- | Qualified expression from qualifier and projection index. +columnFromId :: Qualifier -> Int -> StringSQL +columnFromId qi i = qi <.> columnN i + +-- | From 'Qualified' SQL string into qualified formed 'String' +-- like (SELECT ...) AS T +qualifiedSQLas :: Qualified StringSQL -> StringSQL +qualifiedSQLas q = Syntax.unQualify q <> showQualifier (Syntax.qualifier q) + +-- | Width of 'SubQuery'. +width :: SubQuery -> Int +width = d where + d (Table u) = UntypedTable.width' u + d (Bin _ l _) = width l + d (Flat _ up _ _ _ _) = Syntax.tupleWidth up + d (Aggregated _ up _ _ _ _ _ _) = Syntax.tupleWidth up + +-- | Width of 'Qualified' 'SubQUery'. +queryWidth :: Qualified SubQuery -> Int +queryWidth = width . Syntax.unQualify + +-- | Generate SQL from table for top-level. +fromTableToSQL :: UntypedTable.Untyped -> StringSQL +fromTableToSQL t = + SELECT <> SQL.fold (|*|) (UntypedTable.columns' t) <> + FROM <> stringSQL (UntypedTable.name' t) + +-- | Generate normalized column SQL from table. +fromTableToNormalizedSQL :: UntypedTable.Untyped -> StringSQL +fromTableToNormalizedSQL t = SELECT <> SQL.fold (|*|) columns' <> + FROM <> stringSQL (UntypedTable.name' t) where + columns' = zipWith asColumnN + (UntypedTable.columns' t) + [(0 :: Int)..] + +-- | Generate normalized column SQL from joined tuple. +selectPrefixSQL :: Tuple -> Duplication -> StringSQL +selectPrefixSQL up da = SELECT <> showsDuplication da <> + SQL.fold (|*|) columns' where + columns' = zipWith asColumnN + (map showColumn up) + [(0 :: Int)..] + +-- | Normalized column SQL for union like operations +-- to keep compatibility with engines like Sqlite and MySQL. +-- SQL with no ordering term is not paren-ed. +normalizedSQL :: SubQuery -> StringSQL +normalizedSQL = d where + d (Table t) = fromTableToNormalizedSQL t + d sub@(Bin {}) = showUnitSQL sub + d sub@(Flat _ _ _ _ _ ots) + | null ots = showSQL sub + | otherwise = showUnitSQL sub + d sub@(Aggregated _ _ _ _ _ _ _ ots) + | null ots = showSQL sub + | otherwise = showUnitSQL sub + +-- | SQL string for nested-query and toplevel-SQL. +toSQLs :: SubQuery + -> (StringSQL, StringSQL) -- ^ sub-query SQL and top-level SQL +toSQLs = d where + d (Table u) = (stringSQL $ UntypedTable.name' u, fromTableToSQL u) + d (Bin (BinOp (op, da)) l r) = (SQL.paren q, q) where + q = mconcat [normalizedSQL l, showsSetOp op da, normalizedSQL r] + d (Flat cf up da pd rs od) = (SQL.paren q, q) where + q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs + <> composeOrderBy od + d (Aggregated cf up da pd rs ag grs od) = (SQL.paren q, q) where + q = selectPrefixSQL up da <> showsJoinProduct (productUnitSupport cf) pd <> composeWhere rs + <> composeGroupBy ag <> composeHaving grs <> composeOrderBy od + +showUnitSQL :: SubQuery -> StringSQL +showUnitSQL = fst . toSQLs + +-- | SQL string for nested-qeury. +unitSQL :: SubQuery -> String +unitSQL = showStringSQL . showUnitSQL + +-- | SQL StringSQL for toplevel-SQL. +showSQL :: SubQuery -> StringSQL +showSQL = snd . toSQLs + +-- | SQL string for toplevel-SQL. +toSQL :: SubQuery -> String +toSQL = showStringSQL . showSQL + +-- | Get column SQL string of 'Qualified' 'SubQuery'. +column :: Qualified SubQuery -> Int -> StringSQL +column qs = d (Syntax.unQualify qs) where + q = Syntax.qualifier qs + d (Table u) i = q <.> (u ! i) + d (Bin {}) i = q `columnFromId` i + d (Flat _ up _ _ _ _) i = showTupleIndex up i + d (Aggregated _ up _ _ _ _ _ _) i = showTupleIndex up i + +-- | Make untyped tuple (qualified column list) from joined sub-query ('Qualified' 'SubQuery'). +tupleFromJoinedSubQuery :: Qualified SubQuery -> Tuple +tupleFromJoinedSubQuery qs = d $ Syntax.unQualify qs where + normalized = SubQueryRef <$> traverse (\q -> [0 .. width q - 1]) qs + d (Table _) = map RawColumn . map (column qs) + $ take (queryWidth qs) [0..] + d (Bin {}) = normalized + d (Flat {}) = normalized + d (Aggregated {}) = normalized + +-- | index result of each when clause and else clause. +indexWhensClause :: WhenClauses -> Int -> StringSQL +indexWhensClause (WhenClauses ps e) i = + mconcat [ when' p r | (p, r) <- ps] <> else' <> SQL.END + where + when' p r = SQL.WHEN <> rowStringSQL (map showColumn p) <> + SQL.THEN <> showTupleIndex r i + else' = SQL.ELSE <> showTupleIndex e i + +-- | index result of each when clause and else clause. +caseClause :: CaseClause -> Int -> StringSQL +caseClause c i = d c where + d (CaseSearch wcl) = SQL.CASE <> indexWhensClause wcl i + d (CaseSimple m wcl) = SQL.CASE <> rowStringSQL (map showColumn m) <> indexWhensClause wcl i + +-- | Convert from typed' Column' into column string expression. +showColumn :: Column -> StringSQL +showColumn = d where + d (RawColumn e) = e + d (SubQueryRef qi) = Syntax.qualifier qi `columnFromId` Syntax.unQualify qi + d (Scalar sub) = showUnitSQL sub + d (Case c i) = caseClause c i + +-- | Get column SQL string of 'Tuple'. +showTupleIndex :: Tuple -- ^ Source 'Tuple' + -> Int -- ^ Column index + -> StringSQL -- ^ Result SQL string +showTupleIndex up i + | 0 <= i && i < Syntax.tupleWidth up = + showColumn $ up !! i + | otherwise = + error $ "showTupleIndex: index out of bounds: " ++ show i + +-- | Get column SQL string list of record. +recordRawColumns :: Record c r -- ^ Source 'Record' + -> [StringSQL] -- ^ Result SQL string list +recordRawColumns = map showColumn . Syntax.untypeRecord + + +-- | Show product tree of query into SQL. StringSQL result. +showsQueryProduct :: ProductTree [Predicate Flat] -> StringSQL +showsQueryProduct = rec where + joinType Just' Just' = INNER + joinType Just' Maybe = LEFT + joinType Maybe Just' = RIGHT + joinType Maybe Maybe = FULL + urec n = case Syntax.nodeTree n of + p@(Leaf _) -> rec p + p@(Join {}) -> SQL.paren (rec p) + rec (Leaf q) = qualifiedSQLas $ fmap showUnitSQL q + rec (Join left' right' rs) = + mconcat + [urec left', + joinType (Syntax.nodeAttr left') (Syntax.nodeAttr right'), JOIN, + urec right', + ON, foldr1 SQL.and $ ps ++ concat [ pure $ boolSQL True | null ps ] ] + where ps = [ rowStringSQL $ recordRawColumns p | p <- rs ] + +-- | Shows join product of query. +showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL +showsJoinProduct ups = maybe (up ups) from where + from qp = FROM <> showsQueryProduct qp + up PUSupported = mempty + up PUNotSupported = error "relation: Unit product support mode is disabled!" + + +-- | Compose SQL String from 'QueryRestriction'. +composeRestrict :: Keyword -> [Predicate c] -> StringSQL +composeRestrict k = d where + d [] = mempty + d ps@(_:_) = k <> foldr1 SQL.and [ rowStringSQL $ recordRawColumns p | p <- ps ] + +-- | Compose WHERE clause from 'QueryRestriction'. +composeWhere :: [Predicate Flat] -> StringSQL +composeWhere = composeRestrict WHERE + +-- | Compose HAVING clause from 'QueryRestriction'. +composeHaving :: [Predicate Aggregated] -> StringSQL +composeHaving = composeRestrict HAVING diff --git a/src/Database/Relational/SqlSyntax/Join.hs b/src/Database/Relational/SqlSyntax/Join.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax/Join.hs @@ -0,0 +1,54 @@ +-- | +-- Module : Database.Relational.SqlSyntax.Join +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines product structure to compose SQL join. +module Database.Relational.SqlSyntax.Join ( + -- * Interfaces to manipulate ProductTree type + growProduct, restrictProduct, + ) where + +import Prelude hiding (and, product) +import Control.Applicative (pure) +import Data.Monoid ((<>), mempty) +import Data.DList (DList) + +import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.SqlSyntax.Types + (NodeAttr (..), ProductTree (..), Node (..), Qualified, SubQuery, + Predicate) + + +-- | Push new tree into product right term. +growRight :: Maybe (Node (DList (Predicate Flat))) -- ^ Current tree + -> (NodeAttr, ProductTree (DList (Predicate Flat))) -- ^ New tree to push into right + -> Node (DList (Predicate Flat)) -- ^ Result node +growRight = d where + d Nothing (naR, q) = Node naR q + d (Just l) (naR, q) = Node Just' $ Join l (Node naR q) mempty + +-- | Push new leaf node into product right term. +growProduct :: Maybe (Node (DList (Predicate Flat))) -- ^ Current tree + -> (NodeAttr, Qualified SubQuery) -- ^ New leaf to push into right + -> Node (DList (Predicate Flat)) -- ^ Result node +growProduct = match where + match t (na, q) = growRight t (na, Leaf q) + +-- | Add restriction into top product of product tree. +restrictProduct' :: ProductTree (DList (Predicate Flat)) -- ^ Product to restrict + -> Predicate Flat -- ^ Restriction to add + -> ProductTree (DList (Predicate Flat)) -- ^ Result product +restrictProduct' = d where + d (Join lp rp rs) rs' = Join lp rp (rs <> pure rs') + d leaf'@(Leaf _) _ = leaf' -- or error on compile + +-- | Add restriction into top product of product tree node. +restrictProduct :: Node (DList (Predicate Flat)) -- ^ Target node which has product to restrict + -> Predicate Flat -- ^ Restriction to add + -> Node (DList (Predicate Flat)) -- ^ Result node +restrictProduct (Node a t) e = Node a (restrictProduct' t e) diff --git a/src/Database/Relational/SqlSyntax/Query.hs b/src/Database/Relational/SqlSyntax/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax/Query.hs @@ -0,0 +1,114 @@ +-- | +-- Module : Database.Relational.SqlSyntax.Query +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides building and expanding operations of SQL query tree. +module Database.Relational.SqlSyntax.Query ( + flatSubQuery, aggregatedSubQuery, + union, except, intersect, + caseSearch, case', + + composeOrderBy, + ) where + +import Data.Monoid (mempty, (<>)) + +import Language.SQL.Keyword (Keyword(..), (|*|)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Internal.Config (Config) +import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Relational.Internal.String (StringSQL) +import Database.Relational.SqlSyntax.Types + (Duplication (..), SetOp (..), BinOp (..), + Order (..), Nulls (..), OrderingTerm, AggregateElem, + JoinProduct, Predicate, WhenClauses (..), CaseClause (..), SubQuery (..), + Column (..), Tuple, Record, record, untypeRecord, recordWidth, ) + + +-- | Unsafely generate flat 'SubQuery' from untyped components. +flatSubQuery :: Config + -> Tuple + -> Duplication + -> JoinProduct + -> [Predicate Flat] + -> [OrderingTerm] + -> SubQuery +flatSubQuery = Flat + +-- | Unsafely generate aggregated 'SubQuery' from untyped components. +aggregatedSubQuery :: Config + -> Tuple + -> Duplication + -> JoinProduct + -> [Predicate Flat] + -> [AggregateElem] + -> [Predicate Aggregated] + -> [OrderingTerm] + -> SubQuery +aggregatedSubQuery = Aggregated + +setBin :: SetOp -> Duplication -> SubQuery -> SubQuery -> SubQuery +setBin op = Bin . BinOp . (,) op + +-- | Union binary operator on 'SubQuery' +union :: Duplication -> SubQuery -> SubQuery -> SubQuery +union = setBin Union + +-- | Except binary operator on 'SubQuery' +except :: Duplication -> SubQuery -> SubQuery -> SubQuery +except = setBin Except + +-- | Intersect binary operator on 'SubQuery' +intersect :: Duplication -> SubQuery -> SubQuery -> SubQuery +intersect = setBin Intersect + + +whenClauses :: String -- ^ Error tag + -> [(Record c a, Record c b)] -- ^ Each when clauses + -> Record c b -- ^ Else result record + -> WhenClauses -- ^ Result clause +whenClauses eTag ws0 e = d ws0 + where + d [] = error $ eTag ++ ": Empty when clauses!" + d ws@(_:_) = + WhenClauses [ (untypeRecord p, untypeRecord r) | (p, r) <- ws ] + $ untypeRecord e + +-- | Search case operator correnponding SQL search /CASE/. +-- Like, /CASE WHEN p0 THEN a WHEN p1 THEN b ... ELSE c END/ +caseSearch :: [(Predicate c, Record c a)] -- ^ Each when clauses + -> Record c a -- ^ Else result record + -> Record c a -- ^ Result record +caseSearch ws e = + record [ Case c i | i <- [0 .. recordWidth e - 1] ] + where + c = CaseSearch $ whenClauses "caseSearch" ws e + +-- | Simple case operator correnponding SQL simple /CASE/. +-- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ +case' :: Record c a -- ^ Record value to match + -> [(Record c a, Record c b)] -- ^ Each when clauses + -> Record c b -- ^ Else result record + -> Record c b -- ^ Result record +case' v ws e = + record [ Case c i | i <- [0 .. recordWidth e - 1] ] + where + c = CaseSimple (untypeRecord v) $ whenClauses "case'" ws e + + +-- | 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 diff --git a/src/Database/Relational/SqlSyntax/Types.hs b/src/Database/Relational/SqlSyntax/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax/Types.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + +-- | +-- Module : Database.Relational.SqlSyntax.Types +-- 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.SqlSyntax.Types ( + -- * The SubQuery + SubQuery (..), + + -- * Set operations + Duplication (..), SetOp (..), BinOp (..), + + -- * Qualifiers for nested query + Qualifier (..), Qualified (..), qualifier, unQualify, qualify, + + -- * Ordering types + Order (..), Nulls (..), OrderColumn, OrderingTerm, + + -- * Aggregating types + AggregateColumnRef, + AggregateBitKey (..), AggregateSet (..), AggregateElem (..), + + AggregateKey (..), + + -- * Product tree type + NodeAttr (..), ProductTree (..), + Node (..), nodeAttr, nodeTree, + JoinProduct, + + -- * Case + CaseClause (..), WhenClauses(..), + + -- * Column, Tuple, Record and Projection + Column (..), Tuple, tupleWidth, + Record, untypeRecord, record, PI, + recordWidth, + typeFromRawColumns, + typeFromScalarSubQuery, + + -- * Predicate to restrict Query result + Predicate, + ) where + +import Prelude hiding (and, product) +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) + +import Database.Relational.Internal.Config (Config) +import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Relational.Internal.String (StringSQL) +import Database.Relational.Internal.UntypedTable (Untyped) + + +-- | Result record duplication attribute +data Duplication = All | Distinct deriving Show + +-- | Set operators +data SetOp = Union | Except | Intersect deriving Show + +-- | Set binary operators +newtype BinOp = BinOp (SetOp, Duplication) deriving Show + +-- | Order direction. Ascendant or Descendant. +data Order = Asc | Desc deriving Show + +-- | Order of null. +data Nulls = NullsFirst | NullsLast deriving Show + +-- | Type for order-by column +type OrderColumn = StringSQL + +-- | Type for order-by term +type OrderingTerm = ((Order, Maybe Nulls), OrderColumn) + +-- | 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) + +-- | Sub-query type +data SubQuery = Table Untyped + | Flat Config + Tuple Duplication JoinProduct [Predicate Flat] + [OrderingTerm] + | Aggregated Config + Tuple Duplication JoinProduct [Predicate Flat] + [AggregateElem] [Predicate Aggregated] [OrderingTerm] + | Bin BinOp SubQuery SubQuery + deriving Show + +-- | Qualifier type. +newtype Qualifier = Qualifier Int deriving Show + +-- | Qualified query. +data Qualified a = + Qualified Qualifier a + deriving (Show, Functor, Foldable, Traversable) + +-- | Get qualifier +qualifier :: Qualified a -> Qualifier +qualifier (Qualified q _) = q + +-- | Unqualify. +unQualify :: Qualified a -> a +unQualify (Qualified _ a) = a + +-- | Add qualifier +qualify :: Qualifier -> a -> Qualified a +qualify = Qualified + + +-- | node attribute for product. +data NodeAttr = Just' | Maybe deriving Show + +type QS = Qualified SubQuery + +-- | 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 + +-- | Type for join product of query. +type JoinProduct = Maybe (ProductTree [Predicate Flat]) + +-- | when clauses +data WhenClauses = + WhenClauses [(Tuple, Tuple)] Tuple + deriving Show + +-- | case clause +data CaseClause + = CaseSearch WhenClauses + | CaseSimple Tuple WhenClauses + deriving Show + +-- | Projected column structure unit with single column width +data Column + = RawColumn StringSQL -- ^ used in immediate value or unsafe operations + | SubQueryRef (Qualified Int) -- ^ normalized sub-query reference T with Int index + | Scalar SubQuery -- ^ scalar sub-query + | Case CaseClause Int -- ^ th column of case clause + deriving Show + +-- | Untyped projected tuple. Forgot record type. +type Tuple = [Column] + +-- | Width of 'Tuple'. +tupleWidth :: Tuple -> Int +tupleWidth = length + +-- | Phantom typed record. Projected into Haskell record type 't'. +newtype Record c t = + Record + { untypeRecord :: Tuple {- ^ Discard record type -} } deriving Show + +-- | Type for predicate to restrict of query result. +type Predicate c = Record c (Maybe Bool) + +-- | Type for projection function. +type PI c a b = Record c a -> Record c b + +-- | Unsafely type 'Tuple' value to 'Record' type. +record :: Tuple -> Record c t +record = Record + +-- | Width of 'Record'. +recordWidth :: Record c r -> Int +recordWidth = length . untypeRecord + +-- | Unsafely generate 'Record' from SQL string list. +typeFromRawColumns :: [StringSQL] -- ^ SQL string list specifies columns + -> Record c r -- ^ Result 'Record' +typeFromRawColumns = record . map RawColumn + +-- | Unsafely generate 'Record' from scalar sub-query. +typeFromScalarSubQuery :: SubQuery -> Record c t +typeFromScalarSubQuery = record . (:[]) . Scalar diff --git a/src/Database/Relational/SqlSyntax/Updates.hs b/src/Database/Relational/SqlSyntax/Updates.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/SqlSyntax/Updates.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Database.Relational.SqlSyntax.Updates +-- Copyright : 2013-2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides types and expanding operations of SQL update and insert structure. +module Database.Relational.SqlSyntax.Updates ( + -- * Update and Insert assignments + AssignColumn, AssignTerm, Assignment, + + composeSets, + composeChunkValues, composeChunkValuesWithColumns, + ) where + +import Data.Monoid ((<>)) + +import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) +import qualified Language.SQL.Keyword as SQL + +import Database.Relational.Internal.String (StringSQL, rowConsStringSQL) + + +-- | Column SQL String of assignment +type AssignColumn = StringSQL + +-- | Value SQL String of assignment +type AssignTerm = StringSQL + +-- | Assignment pair +type Assignment = (AssignColumn, AssignTerm) + +-- | Compose SET clause from ['Assignment']. +composeSets :: [Assignment] -> StringSQL +composeSets as = assigns where + assignList = foldr (\ (col, term) r -> + (col .=. term) : r) + [] as + assigns | null assignList = error "Update assignment list is null!" + | otherwise = SET <> SQL.fold (|*|) assignList + +-- | Compose VALUES clause from value expression list. +composeChunkValues :: Int -- ^ record count per chunk + -> [AssignTerm] -- ^ value expression list + -> Keyword +composeChunkValues n0 vs = + VALUES <> cvs + where + n | n0 >= 1 = n0 + | otherwise = error $ "Invalid record count value: " ++ show n0 + cvs = SQL.fold (|*|) . replicate n $ rowConsStringSQL vs + +-- | Compose 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 diff --git a/src/Database/Relational/TH.hs b/src/Database/Relational/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/TH.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ParallelListComp #-} + +-- | +-- Module : Database.Relational.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.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, + + -- * Reify + makeRelationalRecordDefault, + reifyRelation, + ) where + +import Data.Char (toUpper, toLower) +import Data.List (foldl1') +import Data.Array.IArray ((!)) +import Data.Functor.ProductIsomorphic.TH + (reifyRecordType, defineProductConstructor) +import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..)) + +import Language.Haskell.TH + (Name, nameBase, Q, reify, Dec, instanceD, ExpQ, stringE, listE, + TypeQ, Type (AppT, ConT), varT, tupleT, appT, arrowT, classP) +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 + (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.BaseTH (defineTuplePi, defineRecordProjections) +import Database.Relational.Scalar (defineScalarDegree) +import Database.Relational.Constraint (Key, unsafeDefineConstraintKey) +import Database.Relational.Table (TableDerivable (..)) +import qualified Database.Relational.Table as Table +import Database.Relational.Relation (derivedRelation) +import Database.Relational.SimpleSql (QuerySuffix) +import Database.Relational.Type (unsafeTypedQuery) +import qualified Database.Relational.Pi.Unsafe as UnsafePi + + +-- | 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 -> [Q Type] -> Q [Dec] +defineProductConstructorInstanceWithConfig config schema table colTypes = do + let (recType, recData) = recordTemplate (recordConfig $ nameConfig config) schema table + [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recType colTypes) where + productConstructor = $(recData) + |] + +-- | Make templates about table and column metadatas using specified naming rule. +defineTableTypesWithConfig :: Config -- ^ Configuration to generate query with + -> String -- ^ Schema name + -> String -- ^ Table name + -> [((String, TypeQ), 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, vars), _dataCon), (mayNs, cts)) <- reifyRecordType recTypeName + pw <- Record.definePersistableWidthInstance tyCon vars + cols <- case mayNs of + Nothing -> return [] + Just ns -> case vars of + [] -> do {- monomorphic case -} + off <- Record.defineColumnOffsets recTypeConName + cs <- defineColumnsDefault recTypeConName + [ ((nameBase n, ct), Nothing) | n <- ns | ct <- cts ] + return $ off ++ cs + _:_ -> {- polymorphic case -} + defineRecordProjections tyCon vars + [varName $ varCamelcaseName (nameBase n ++ "'") | n <- ns] + cts + + pc <- defineProductConstructor recTypeName + let scPred v = classP ''ShowConstantTermsSQL [varT v] + ct <- instanceD (mapM scPred vars) (appT [t| ShowConstantTermsSQL |] tyCon) [] + return $ concat [pw, cols, pc, [ct]] diff --git a/src/Database/Relational/Table.hs b/src/Database/Relational/Table.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Table.hs @@ -0,0 +1,81 @@ +-- | +-- Module : Database.Relational.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.Table ( + -- * Phantom typed table type + Table, unType, name, shortName, width, columns, index, table, toMaybe, recordWidth, + toSubQuery, + + -- * Table existence inference + TableDerivable (..) + ) where + +import Data.Array (listArray) + +import Database.Record.Persistable + (PersistableWidth, PersistableRecordWidth, unsafePersistableRecordWidth) + +import Database.Relational.Internal.UntypedTable (Untyped (Untyped), name', width', columns', (!)) +import Database.Relational.Internal.String (StringSQL, stringSQL, ) +import Database.Relational.SqlSyntax (SubQuery) +import qualified Database.Relational.SqlSyntax as Syntax + + +-- | 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 + +-- | 'SubQuery' from 'Table'. +toSubQuery :: Table r -- ^ Typed 'Table' metadata + -> SubQuery -- ^ Result 'SubQuery' +toSubQuery = Syntax.Table . unType + +-- | Inference rule of 'Table' existence. +class PersistableWidth r => TableDerivable r where + derivedTable :: Table r + +-- | PersistableRecordWidth of table +recordWidth :: Table r -> PersistableRecordWidth r +recordWidth = unsafePersistableRecordWidth . width diff --git a/src/Database/Relational/TupleInstances.hs b/src/Database/Relational/TupleInstances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/TupleInstances.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Database.Relational.TupleInstances +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines ProductConstructor instances and projection path objects of tuple types. +module Database.Relational.TupleInstances where + +import Control.Applicative ((<$>)) + +import Database.Relational.BaseTH + (defineTuplePi, defineTupleShowConstantInstance,) + + +$(concat <$> mapM defineTuplePi [2..7]) +$(concat <$> mapM defineTupleShowConstantInstance [2..7]) +-- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics. diff --git a/src/Database/Relational/Type.hs b/src/Database/Relational/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Type.hs @@ -0,0 +1,334 @@ +-- | +-- Module : Database.Relational.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.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, + + 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.Internal.Config (Config, defaultConfig) +import Database.Relational.Internal.String (showStringSQL) + +import Database.Relational.Monad.BaseType (Relation, sqlFromRelationWith) +import Database.Relational.Monad.Restrict (RestrictedStatement) +import Database.Relational.Monad.Assign (AssignStatement) +import Database.Relational.Monad.Register (Register) +import Database.Relational.Relation (tableOf) +import Database.Relational.Effect + (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget', + sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget) +import Database.Relational.Pi (Pi) +import Database.Relational.Table (Table, TableDerivable, derivedTable) +import Database.Relational.Projectable (PlaceHolders) +import Database.Relational.SimpleSql + (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 + +-- | 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 diff --git a/test/Model.hs b/test/Model.hs --- a/test/Model.hs +++ b/test/Model.hs @@ -9,8 +9,8 @@ import GHC.Generics (Generic) import Data.Int (Int32, Int64) -import Database.Relational.Query (defaultConfig) -import Database.Relational.Query.TH (defineTable, makeRelationalRecordDefault, defineScalarDegree) +import Database.Relational (defaultConfig) +import Database.Relational.TH (defineTable, makeRelationalRecordDefault, defineScalarDegree) $(defineTable defaultConfig "TEST" "set_a" diff --git a/test/sqlsEq.hs b/test/sqlsEq.hs --- a/test/sqlsEq.hs +++ b/test/sqlsEq.hs @@ -2,15 +2,16 @@ import Test.QuickCheck.Simple (Test, defaultMain) import qualified Test.QuickCheck.Simple as QSimple -import Control.Applicative ((<$>), (<*>)) - import Lex (eqProp, eqProp') import Model +import Control.Applicative ((<$>), (<*>)) +import Data.Functor.ProductIsomorphic ((|$|), (|*|)) import Data.Int (Int32, Int64) -import Database.Relational.Query +import Database.Relational + tables :: [Test] tables = [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" @@ -282,9 +283,9 @@ _p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] --- Projection Operators +-- Record Operators -bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r +bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> Relation () r bin53 op = relation $ do return $ value 5 `op` value 3 @@ -292,7 +293,7 @@ strIn = relation $ return $ value "foo" `in'` values ["foo", "bar"] -boolTF :: (Projection Flat (Maybe Bool) -> Projection Flat (Maybe Bool) -> Projection Flat r) -> Relation () r +boolTF :: (Record Flat (Maybe Bool) -> Record Flat (Maybe Bool) -> Record Flat r) -> Relation () r boolTF op = relation $ do return $ valueTrue `op` valueFalse @@ -304,7 +305,7 @@ strLike = relation $ do return $ value "Hoge" `like` "H%" -_p_bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO () +_p_bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> IO () _p_bin53 = print . bin53 bin :: [Test] diff --git a/test/sqlsEqArrow.hs b/test/sqlsEqArrow.hs --- a/test/sqlsEqArrow.hs +++ b/test/sqlsEqArrow.hs @@ -6,10 +6,12 @@ import Lex (eqProp, eqProp') import Model -import Data.Int (Int32, Int64) import Control.Arrow (returnA, arr, (<<<), (***)) -import Database.Relational.Query.Arrow +import Data.Int (Int32, Int64) +import Data.Functor.ProductIsomorphic ((|$|), (|*|)) +import Database.Relational.Arrow + tables :: [Test] tables = [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" @@ -278,9 +280,9 @@ _p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] --- Projection Operators +-- Record Operators -bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> Relation () r +bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> Relation () r bin53 op = relation $ proc () -> do returnA -< value 5 `op` value 3 @@ -288,7 +290,7 @@ 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 :: (Record Flat (Maybe Bool) -> Record Flat (Maybe Bool) -> Record Flat r) -> Relation () r boolTF op = relation $ proc () -> do returnA -< valueTrue `op` valueFalse @@ -300,7 +302,7 @@ strLike = relation $ proc () -> do returnA -< value "Hoge" `like` "H%" -_p_bin53 :: (Projection Flat Int32 -> Projection Flat Int32 -> Projection Flat r) -> IO () +_p_bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> IO () _p_bin53 = print . bin53 bin :: [Test]