From 3c7b578428c0c875779c8266beafccee0e07cef2 Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Fri, 17 May 2019 15:21:31 +0900 Subject: [PATCH 1/7] Safer placeholders Improvements from https://github.com/khibino/haskell-relational-record/pull/70 - Wrap everything created from a `Record` with `WithPlaceholderOffsets`. - Which can be easily concatenated by `Applicative` combinators such as `<*>`. - Better solution than https://github.com/khibino/haskell-relational-record/pull/70#issuecomment-473622160 and https://github.com/khibino/haskell-relational-record/pull/70#issuecomment-473633258 - (BREAKING CHANGE) Pass placeholders Record directly to `query'` etc. - Delete old (and unavailable anymore) placholders-related APIs: `placeholder` and `relation'` etc. Left Tasks ==== - Some tests doesn't pass. Fix them. - Avoid to use `toFlat` and `toAggregated` as much as possible: `ResultContext` should be adapted. - Add tests for placeholders. - You may want to refactor the design. --- persistable-types-HDBC-pg/test/runTest.hs | 10 +- .../src/Database/HDBC/Query/TH.hs | 6 +- .../src/Database/HDBC/Record/Insert.hs | 10 +- .../src/Database/HDBC/Record/KeyUpdate.hs | 19 +- .../src/Database/HDBC/Record/Statement.hs | 27 ++- relational-query/relational-query.cabal | 3 + relational-query/src/Database/Relational.hs | 14 +- .../src/Database/Relational/Arrow.hs | 129 +++++------ .../src/Database/Relational/Derives.hs | 11 +- .../src/Database/Relational/Effect.hs | 172 ++++++++------- .../Relational/Internal/ContextType.hs | 5 +- .../Database/Relational/Monad/Aggregate.hs | 44 ++-- .../src/Database/Relational/Monad/Assign.hs | 22 +- .../src/Database/Relational/Monad/BaseType.hs | 86 +++++--- .../src/Database/Relational/Monad/Class.hs | 19 +- .../src/Database/Relational/Monad/Register.hs | 4 +- .../src/Database/Relational/Monad/Restrict.hs | 7 +- .../src/Database/Relational/Monad/Simple.hs | 23 +- .../Relational/Monad/Trans/Aggregating.hs | 81 +++++-- .../Relational/Monad/Trans/Assigning.hs | 26 ++- .../Database/Relational/Monad/Trans/Join.hs | 49 +++-- .../Relational/Monad/Trans/JoinState.hs | 7 +- .../Relational/Monad/Trans/Ordering.hs | 33 +-- .../Monad/Trans/ReadPlaceholders.hs | 42 ++++ .../Monad/Trans/ReadPlaceholders/Type.hs | 42 ++++ .../Relational/Monad/Trans/Restricting.hs | 21 +- .../src/Database/Relational/Monad/Type.hs | 7 +- .../src/Database/Relational/Monad/Unique.hs | 17 +- .../src/Database/Relational/Projectable.hs | 117 ++++------ .../Relational/Projectable/Instances.hs | 42 ++-- .../Database/Relational/Projectable/Unsafe.hs | 16 +- .../src/Database/Relational/Record.hs | 75 +++++-- .../src/Database/Relational/Relation.hs | 106 +++++---- .../src/Database/Relational/Sequence.hs | 10 +- .../src/Database/Relational/Set.hs | 75 ++++--- .../src/Database/Relational/SqlSyntax.hs | 2 + .../src/Database/Relational/SqlSyntax/Fold.hs | 74 +++++-- .../src/Database/Relational/SqlSyntax/Join.hs | 4 +- .../Relational/SqlSyntax/Placeholders.hs | 91 ++++++++ .../Database/Relational/SqlSyntax/Query.hs | 35 +-- .../Database/Relational/SqlSyntax/Types.hs | 90 +++++--- .../Database/Relational/SqlSyntax/Updates.hs | 38 ++-- .../src/Database/Relational/TH.hs | 17 +- .../src/Database/Relational/Type.hs | 207 +++++++++--------- relational-query/test/sqlsEq.hs | 60 ++--- relational-query/test/sqlsEqArrow.hs | 46 ++-- relational-record-examples/mains/examples.hs | 129 +++++------ .../mains/specializedExamples.hs | 128 +++++------ .../src/Database/Relational/Documentation.hs | 4 - relational-schemas/relational-schemas.cabal | 1 + .../src/Database/Custom/IBMDB2.hs | 30 +-- .../src/Database/Custom/MySQL.hs | 30 +-- .../src/Database/Custom/Oracle.hs | 30 +-- .../src/Database/Custom/PostgreSQL.hs | 30 +-- .../src/Database/Custom/SQLServer.hs | 30 +-- .../src/Database/Custom/SQLite3.hs | 30 +-- .../src/Database/Relational/Schema/IBMDB2.hs | 24 +- .../src/Database/Relational/Schema/MySQL.hs | 23 +- .../src/Database/Relational/Schema/Oracle.hs | 24 +- .../Database/Relational/Schema/PostgreSQL.hs | 66 +++--- .../Database/Relational/Schema/SQLServer.hs | 40 ++-- .../src/Database/Relational/Schema/SQLite3.hs | 7 +- 62 files changed, 1528 insertions(+), 1139 deletions(-) create mode 100644 relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders.hs create mode 100644 relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders/Type.hs create mode 100644 relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs diff --git a/persistable-types-HDBC-pg/test/runTest.hs b/persistable-types-HDBC-pg/test/runTest.hs index dad4d7b1..d55fbd13 100644 --- a/persistable-types-HDBC-pg/test/runTest.hs +++ b/persistable-types-HDBC-pg/test/runTest.hs @@ -12,7 +12,7 @@ import Database.HDBC.Query.TH (makeRelationalRecord) import Data.PostgreSQL.NetworkAddress (Inet (..), Cidr (..), NetAddress (..), V4HostAddress (..), V6HostAddress (..)) -import Database.Relational (Relation, relation, value) +import Database.Relational (Relation, relation, value, toFlat) import Database.HDBC.PostgreSQL.Persistable () @@ -30,25 +30,25 @@ $(makeRelationalRecord ''Foo) -- 192.168.0.1/24 inet4 :: Relation () Inet inet4 = - relation . return . value . Inet $ + relation . return . toFlat . value . Inet $ NetAddress4 (V4HostAddress 192 168 0 1) 24 -- 224.0.0.0/4 cidr4 :: Relation () Cidr cidr4 = - relation . return . value . Cidr $ + relation . return . toFlat . value . Cidr $ NetAddress4 (V4HostAddress 224 0 0 0) 4 -- fd00::1/8 inet6 :: Relation () Inet inet6 = - relation . return . value . Inet $ + relation . return . toFlat . value . Inet $ NetAddress6 (V6HostAddress 0xfd00 0 0 0 0 0 0 1) 8 -- ff00::/8 cidr6 :: Relation () Cidr cidr6 = - relation . return . value . Cidr $ + relation . return . toFlat . value . Cidr $ NetAddress6 (V6HostAddress 0xff00 0 0 0 0 0 0 0) 8 testSet :: [(String, String, [String])] diff --git a/relational-query-HDBC/src/Database/HDBC/Query/TH.hs b/relational-query-HDBC/src/Database/HDBC/Query/TH.hs index 4ab64943..4264c1e5 100644 --- a/relational-query-HDBC/src/Database/HDBC/Query/TH.hs +++ b/relational-query-HDBC/src/Database/HDBC/Query/TH.hs @@ -39,11 +39,11 @@ import Language.Haskell.TH (Q, runIO, Name, TypeQ, Type (AppT, ConT), Dec) import Language.Haskell.TH.Lib.Extra (reportWarning, reportError) import Language.SQL.Keyword (Keyword) -import Database.Record (ToSql, FromSql) +import Database.Record (ToSql, FromSql, PersistableWidth) import Database.Record.TH (recordTemplate, defineSqlPersistableInstances) import Database.Relational (Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning, - defaultConfig, Relation) + defaultConfig, Relation, relationalQuerySQL, QuerySuffix, detachPlaceholderOffsets, ) import qualified Database.Relational.TH as Relational import Database.HDBC.Session (withConnectionIO) @@ -171,7 +171,7 @@ defineTableFromDB :: IConnection conn defineTableFromDB connect driver tbl scm = tableAlongWithSchema connect driver tbl scm [] -- | Verify composed 'Query' and inline it in compile type. -inlineVerifiedQuery :: IConnection conn +inlineVerifiedQuery :: (IConnection conn, PersistableWidth p) => IO conn -- ^ Connect action to system catalog database -> Name -- ^ Top-level variable name which has 'Relation' type -> Relation p r -- ^ Object which has 'Relation' type diff --git a/relational-query-HDBC/src/Database/HDBC/Record/Insert.hs b/relational-query-HDBC/src/Database/HDBC/Record/Insert.hs index 88d3d976..51da4951 100644 --- a/relational-query-HDBC/src/Database/HDBC/Record/Insert.hs +++ b/relational-query-HDBC/src/Database/HDBC/Record/Insert.hs @@ -28,7 +28,9 @@ import Control.Monad (unless) import System.IO.Unsafe (unsafeInterleaveIO) import Database.HDBC (IConnection, SqlValue) -import Database.Relational (Insert (..), untypeChunkInsert, chunkSizeOfInsert) +import Database.Relational + (Insert (..), untypeChunkInsert, chunkSizeOfInsert, + detachPlaceholderOffsets, placeholderOffsets, sortByPlaceholderOffsets) import Database.Record (ToSql, fromRecord) import Database.HDBC.Record.Statement @@ -80,7 +82,11 @@ mapInsert = mapNoFetch -- | Unsafely bind chunk of records. chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement () -chunkBind q ps = BoundStatement { bound = untypePrepared q, params = ps >>= fromRecord } +chunkBind q ps = BoundStatement { bound = st, params = concatMap (sortByPlaceholderOffsets phs . fromRecord) ps } + where + stphs = untypePrepared q + st = detachPlaceholderOffsets stphs + phs = placeholderOffsets stphs withPrepareChunksInsert :: (IConnection conn, ToSql SqlValue a) => conn diff --git a/relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs b/relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs index c7b63537..9ff81308 100644 --- a/relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs +++ b/relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs @@ -22,11 +22,13 @@ module Database.HDBC.Record.KeyUpdate ( ) where import Control.Exception (bracket) +import Data.Traversable (traverse) import Database.HDBC (IConnection, SqlValue, Statement) import qualified Database.HDBC as HDBC import Database.Relational - (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi) + (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi, + WithPlaceholderOffsets, placeholderOffsets, detachPlaceholderOffsets, sortByPlaceholderOffsets, ) import qualified Database.Relational as DSL import Database.Record (ToSql) @@ -41,7 +43,7 @@ data PreparedKeyUpdate p a = -- | Key to specify update target records. updateKey :: Pi a p -- | Untyped prepared statement before executed. - , preparedKeyUpdate :: Statement + , preparedKeyUpdate :: WithPlaceholderOffsets Statement } -- | Typed prepare key-update operation. @@ -49,7 +51,7 @@ prepare :: IConnection conn => conn -> KeyUpdate p a -> IO (PreparedKeyUpdate p a) -prepare conn ku = fmap (PreparedKeyUpdate key) . HDBC.prepare conn $ sql where +prepare conn ku = fmap (PreparedKeyUpdate key) . traverse (HDBC.prepare conn) $ sql where sql = untypeKeyUpdate ku key = DSL.updateKey ku @@ -67,7 +69,7 @@ withPrepareKeyUpdate :: IConnection conn -> (PreparedKeyUpdate p a -> IO b) -> IO b withPrepareKeyUpdate conn ku body = - bracket (HDBC.prepare conn sql) HDBC.finish + bracket (traverse (HDBC.prepare conn) sql) (HDBC.finish . detachPlaceholderOffsets) $ body . PreparedKeyUpdate key where sql = untypeKeyUpdate ku @@ -79,8 +81,13 @@ bindKeyUpdate :: ToSql SqlValue a -> a -> BoundStatement () bindKeyUpdate pre a = - BoundStatement { bound = preparedKeyUpdate pre, params = updateValuesWithKey key a } - where key = updateKey pre + BoundStatement { bound = st, params = ps } + where + key = updateKey pre + stphs = preparedKeyUpdate pre + st = detachPlaceholderOffsets stphs + phs = placeholderOffsets stphs + ps = sortByPlaceholderOffsets phs $ updateValuesWithKey key a -- | Bind parameters, execute statement and get execution result. runPreparedKeyUpdate :: ToSql SqlValue a diff --git a/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs b/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs index 287abb07..b09beafd 100644 --- a/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs +++ b/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs @@ -31,7 +31,10 @@ module Database.HDBC.Record.Statement ( ) where import Control.Exception (bracket) -import Database.Relational (UntypeableNoFetch (untypeNoFetch)) +import Database.Relational + (UntypeableNoFetch (untypeNoFetch), + sortByPlaceholderOffsets, + WithPlaceholderOffsets, SQLWithPlaceholderOffsets, detachPlaceholderOffsets, placeholderOffsets) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC @@ -41,8 +44,8 @@ import Database.Record (ToSql, fromRecord) newtype PreparedStatement p a = PreparedStatement { -- | Untyped prepared statement before executed. - prepared :: Statement - } + prepared :: WithPlaceholderOffsets Statement + } -- | Typed prepared statement which has bound placeholder parameters. data BoundStatement a = @@ -64,15 +67,15 @@ data ExecutedStatement a = } -- | Unsafely untype prepared statement. -untypePrepared :: PreparedStatement p a -> Statement +untypePrepared :: PreparedStatement p a -> WithPlaceholderOffsets Statement untypePrepared = prepared -- | Run prepare and unsafely make Typed prepared statement. unsafePrepare :: IConnection conn => conn -- ^ Database connection - -> String -- ^ Raw SQL String + -> SQLWithPlaceholderOffsets -- ^ Raw SQL String -> IO (PreparedStatement p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' -unsafePrepare conn = fmap PreparedStatement . HDBC.prepare conn +unsafePrepare conn = fmap PreparedStatement . traverse (HDBC.prepare conn) -- | Generalized prepare inferred from 'UntypeableNoFetch' instance. prepareNoFetch :: (UntypeableNoFetch s, IConnection conn) @@ -85,15 +88,15 @@ prepareNoFetch conn = unsafePrepare conn . untypeNoFetch -- PreparedStatement is released on closing connection, -- so connection pooling cases often cause resource leaks. finish :: PreparedStatement p a -> IO () -finish = HDBC.finish . prepared +finish = HDBC.finish . detachPlaceholderOffsets . prepared -- | Bracketed prepare operation. -- Unsafely make Typed prepared statement. -- PreparedStatement is released on closing connection, -- so connection pooling cases often cause resource leaks. withUnsafePrepare :: IConnection conn - => conn -- ^ Database connection - -> String -- ^ Raw SQL String + => conn -- ^ Database connection + -> SQLWithPlaceholderOffsets -- ^ Raw SQL String -> (PreparedStatement p a -> IO b) -> IO b withUnsafePrepare conn qs = @@ -114,7 +117,11 @@ bind :: ToSql SqlValue p => PreparedStatement p a -- ^ Prepared query to bind to -> p -- ^ Parameter to bind -> BoundStatement a -- ^ Result parameter bound statement -bind q p = BoundStatement { bound = prepared q, params = fromRecord p } +bind q p = BoundStatement { bound = st, params = sortByPlaceholderOffsets phs $ fromRecord p } + where + stphs = untypePrepared q + st = detachPlaceholderOffsets stphs + phs = placeholderOffsets stphs -- | Same as 'bind' except for argument is flipped. bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a diff --git a/relational-query/relational-query.cabal b/relational-query/relational-query.cabal index 6517297e..2068628e 100644 --- a/relational-query/relational-query.cabal +++ b/relational-query/relational-query.cabal @@ -59,6 +59,7 @@ library Database.Relational.Monad.Trans.Restricting Database.Relational.Monad.Trans.Join Database.Relational.Monad.Trans.Config + Database.Relational.Monad.Trans.ReadPlaceholders Database.Relational.Monad.Trans.Assigning Database.Relational.Monad.Type Database.Relational.Monad.Simple @@ -92,8 +93,10 @@ library Database.Relational.SqlSyntax.Query Database.Relational.SqlSyntax.Fold Database.Relational.SqlSyntax.Updates + Database.Relational.SqlSyntax.Placeholders Database.Relational.Monad.Trans.JoinState Database.Relational.Monad.Trans.Qualify + Database.Relational.Monad.Trans.ReadPlaceholders.Type Database.Relational.InternalTH.Base -- for GHC version equal or more than 8.0 diff --git a/relational-query/src/Database/Relational.hs b/relational-query/src/Database/Relational.hs index aafb4f3b..52b2895d 100644 --- a/relational-query/src/Database/Relational.hs +++ b/relational-query/src/Database/Relational.hs @@ -24,7 +24,6 @@ module Database.Relational ( 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, @@ -32,13 +31,14 @@ module Database.Relational ( module Database.Relational.Monad.Unique, module Database.Relational.Monad.Assign, module Database.Relational.Monad.Register, + module Database.Relational.Monad.Trans.ReadPlaceholders, module Database.Relational.Relation, module Database.Relational.Set, module Database.Relational.Sequence, module Database.Relational.Scalar, module Database.Relational.Type, module Database.Relational.Effect, - module Database.Relational.Derives + module Database.Relational.Derives, ) where import Database.Relational.Table (Table, TableDerivable (..)) @@ -55,8 +55,10 @@ 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) + WithPlaceholderOffsets, SQLWithPlaceholderOffsets, SQLWithPlaceholderOffsets', + SubQuery, unitSQL, queryWidth, + withPlaceholderOffsets, attachEmptyPlaceholderOffsets, detachPlaceholderOffsets, sortByPlaceholderOffsets, placeholderOffsets, ) +import Database.Relational.Record (RecordList, list, pempty, toFlat, toAggregated) import Database.Relational.ProjectableClass import Database.Relational.Projectable import Database.Relational.TupleInstances @@ -72,14 +74,14 @@ import Database.Relational.Monad.Trans.Ordering (Orderings, orderBy', orderBy, asc, desc) import Database.Relational.Monad.Trans.Aggregating (key, key', set, bkey, rollup, cube, groupingSets) -import Database.Relational.Monad.Trans.Assigning (assignTo, (<-#)) +import Database.Relational.Monad.Trans.ReadPlaceholders 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.Assign (Assign, assignTo, (<-#)) import Database.Relational.Monad.Register (Register) import Database.Relational.Relation import Database.Relational.Set diff --git a/relational-query/src/Database/Relational/Arrow.hs b/relational-query/src/Database/Relational/Arrow.hs index d0976a23..59238a48 100644 --- a/relational-query/src/Database/Relational/Arrow.hs +++ b/relational-query/src/Database/Relational/Arrow.hs @@ -33,7 +33,7 @@ module Database.Relational.Arrow ( uniqueQuery', uniqueQueryMaybe', - on, wheres, having, groupBy, placeholder, + on, wheres, having, groupBy, relation, relation', aggregateRelation, aggregateRelation', @@ -52,6 +52,8 @@ module Database.Relational.Arrow ( insertValue', insertValue, insertValueNoPH, delete', delete, deleteNoPH, + askPlaceholders, + QueryA, QuerySimple, QueryAggregate, QueryUnique, @@ -78,18 +80,18 @@ import Database.Relational hiding query, queryMaybe, query', queryMaybe', queryList, queryList', queryScalar, queryScalar', uniqueQuery', uniqueQueryMaybe', - on, wheres, having, groupBy, placeholder, + on, wheres, having, groupBy, relation, relation', aggregateRelation, aggregateRelation', uniqueRelation', groupBy', key, key', set, bkey, rollup, cube, groupingSets, orderBy', orderBy, asc, desc, partitionBy, over, update', update, updateNoPH, derivedUpdate', derivedUpdate, updateAllColumn', updateAllColumn, updateAllColumnNoPH, insertValue', insertValue, insertValueNoPH, derivedInsertValue', derivedInsertValue, - delete', delete, deleteNoPH, derivedDelete', derivedDelete, + delete', delete, deleteNoPH, derivedDelete', derivedDelete, askPlaceholders, QuerySimple, QueryAggregate, QueryUnique, Orderings, Window, Register) import qualified Database.Relational as Monadic import qualified Database.Relational.Monad.Trans.Aggregating as Monadic -import qualified Database.Relational.Monad.Trans.Assigning as Monadic +import qualified Database.Relational.Monad.Trans.Assigning as MonadicAssigning -- | Arrow to build queries. @@ -129,13 +131,13 @@ type Orderings c m = QueryA (Monadic.Orderings c m) type Window c = QueryA (Monadic.Window c) -- | Arrow type corresponding to 'Monadic.Assignings' -type Assignings r m = QueryA (Monadic.Assignings r m) +type Assignings p r m = QueryA (Monadic.ReadPlaceholders p (MonadicAssigning.Assignings r m)) -- | Arrow type corresponding to 'Monadic.AssignStatement' -type AssignStatement r a = QueryA (Monadic.Assignings r Restrict) (Record Flat r) a +type AssignStatement p r a = QueryA (Monadic.ReadPlaceholders p (MonadicAssigning.Assignings r Restrict)) (Record Flat r) a -- | Arrow type corresponding to 'Monadic.Register' -type Register r a = QueryA (Monadic.Register r) () a +type Register p r a = QueryA (Monadic.ReadPlaceholders p (Monadic.Register r)) () a -- | Arrow type corresponding to 'Monadic.RestrictedStatement' type RestrictedStatement r a = QueryA Monadic.Restrict (Record Flat r) a @@ -164,24 +166,24 @@ 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 + => Relation p r -> QueryA m (Record PureOperand p) (Record Flat r) +query' r = queryA $ \phs -> Monadic.query' phs 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 + => Relation p r -> QueryA m (Record PureOperand p) (Record Flat (Maybe r)) +queryMaybe' r = queryA $ \phs -> Monadic.queryMaybe' phs r unsafeQueryList :: MonadQualify ConfigureQuery m - => (a -> Relation () r) - -> QueryA m a (RecordList (Record c) r) + => (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 + => (a -> Relation p r) + -> QueryA m (Record PureOperand p, a) (RecordList (Record c) r) +unsafeQueryList' rf = queryA $ \(phs, x) -> Monadic.queryList' phs $ rf x -- | Same as 'Monadic.queryList'. Arrow version. -- The result arrow is designed to be injected by local projected records. @@ -194,7 +196,7 @@ queryList = unsafeQueryList -- 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) + -> QueryA m (Record PureOperand p, Record c a) (RecordList (Record c) r) queryList' = unsafeQueryList' -- | Same as 'Monadic.queryList' to pass this result to 'exists' operator. Arrow version. @@ -208,7 +210,7 @@ queryExists = unsafeQueryList -- 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) + -> QueryA m (Record PureOperand p, Record c a) (RecordList (Record Exists) r) queryExists' = unsafeQueryList' -- | Same as 'Monadic.queryList'. Arrow version. @@ -222,8 +224,8 @@ queryListU r = unsafeQueryList $ \() -> r -- 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 + -> QueryA m (Record PureOperand p) (RecordList (Record c) r) +queryListU' r = queryA $ \phs -> Monadic.queryList' phs r unsafeQueryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => (a -> UniqueRelation () c r) @@ -232,8 +234,8 @@ 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 + -> QueryA m (Record PureOperand p, a) (Record c (Maybe r)) +unsafeQueryScalar' rf = queryA $ \(phs, x) -> Monadic.queryScalar' phs $ rf x -- | Same as 'Monadic.queryScalar'. Arrow version. -- The result arrow is designed to be injected by any local projected record. @@ -246,7 +248,7 @@ queryScalar = unsafeQueryScalar -- 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)) + -> QueryA m (Record PureOperand p, Record c a) (Record c (Maybe r)) queryScalar' = unsafeQueryScalar' -- | Same as 'Monadic.queryScalar'. Arrow version. @@ -260,20 +262,20 @@ queryScalarU r = unsafeQueryScalar $ \() -> r -- 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 + -> QueryA m (Record PureOperand p) (Record c (Maybe r)) +queryScalarU' r = queryA $ \phs -> Monadic.queryScalar' phs 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 + -> QueryA Monadic.QueryUnique (Record PureOperand p) (Record c r) +uniqueQuery' r = queryA $ \phs -> Monadic.uniqueQuery' phs 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 + -> QueryA Monadic.QueryUnique (Record PureOperand p) (Record c (Maybe r)) +uniqueQueryMaybe' r = queryA $ \phs -> Monadic.uniqueQueryMaybe' phs r -- | Same as 'Monadic.on'. Arrow version. -- The result arrow is designed to be injected by local conditional flat-records. @@ -299,12 +301,6 @@ 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) @@ -313,9 +309,10 @@ 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' :: PersistableWidth p + => QuerySimple (Record PureOperand p) (Record Flat r) -> Relation p r -relation' = runAofM Monadic.relation' +relation' = Monadic.relation' . runQueryA -- | Same as 'Monadic.aggregateRelation'. -- Finalize query-building arrow instead of query-building monad. @@ -325,15 +322,17 @@ aggregateRelation = runAofM Monadic.aggregateRelation -- | Same as 'Monadic.aggregateRelation''. -- Finalize query-building arrow instead of query-building monad. -aggregateRelation' :: QueryAggregate () (PlaceHolders p, Record Aggregated r) +aggregateRelation' :: PersistableWidth p + => QueryAggregate (Record PureOperand p) (Record Aggregated r) -> Relation p r -aggregateRelation' = runAofM Monadic.aggregateRelation' +aggregateRelation' = Monadic.aggregateRelation' . runQueryA -- | Same as 'Monadic.uniqueRelation''. -- Finalize query-building arrow instead of query-building monad. -uniqueRelation' :: QueryUnique () (PlaceHolders p, Record c r) +uniqueRelation' :: PersistableWidth p + => QueryUnique (Record PureOperand p) (Record c r) -> UniqueRelation p c r -uniqueRelation' = runAofM Monadic.uniqueRelation' +uniqueRelation' = Monadic.uniqueRelation' . runQueryA -- | Same as 'Monadic.groupBy''. -- This arrow is designed to be injected by local 'AggregateKey'. @@ -418,105 +417,109 @@ 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) () + => MonadicAssigning.AssignTarget r v + -> Assignings p r m (Record Flat v) () assign t = queryA (`Monadic.assignTo` t) -- | Same as 'Monadic.update''. -- Make 'Update' from assigning statement arrow using configuration. -update' :: TableDerivable r => Config -> QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p +update' :: (PersistableWidth p, TableDerivable r) => Config -> QueryA (Monadic.ReadPlaceholders p (MonadicAssigning.Assignings r Restrict)) (Record Flat r) () -> Update p update' config = Monadic.update' config . runQueryA -- | Same as 'Monadic.update'. -- Make 'Update' from assigning statement arrow. -update :: TableDerivable r => QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p +update :: (PersistableWidth p, TableDerivable r) => QueryA (Monadic.ReadPlaceholders p (MonadicAssigning.Assignings r Restrict)) (Record Flat r) () -> Update p update = Monadic.update . runQueryA -- | Same as 'Monadic.updateNoPH'. -- Make 'Update' from assigning statement arrow. -updateNoPH :: TableDerivable r => QueryA (Monadic.Assignings r Restrict) (Record Flat r) () -> Update () +updateNoPH :: TableDerivable r => QueryA (Monadic.ReadPlaceholders () (MonadicAssigning.Assignings r Restrict)) (Record Flat r) () -> Update () updateNoPH = Monadic.updateNoPH . runQueryA -- | Same as 'Monadic.updateAllColumn''. -- Make 'Update' from restrected statement arrow. -updateAllColumn' :: (PersistableWidth r, TableDerivable r) +updateAllColumn' :: (PersistableWidth p, PersistableWidth r, TableDerivable r) => Config - -> QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) + -> QueryA (ReadPlaceholders p Monadic.Restrict) (Record Flat r) () -> Update (r, p) updateAllColumn' config = Monadic.updateAllColumn' config . runQueryA -- | Same as 'Monadic.updateAllColumn'. -- Make 'Update' from restrected statement arrow. -updateAllColumn :: (PersistableWidth r, TableDerivable r) - => QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) +updateAllColumn :: (PersistableWidth p, PersistableWidth r, TableDerivable r) + => QueryA (ReadPlaceholders p Monadic.Restrict) (Record Flat r) () -> Update (r, p) updateAllColumn = Monadic.updateAllColumn . runQueryA -- | Same as 'Monadic.updateAllColumnNoPH'. -- Make 'Update' from restrected statement arrow. updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r) - => QueryA Monadic.Restrict (Record Flat r) () + => QueryA (Monadic.ReadPlaceholders () Monadic.Restrict) (Record Flat r) () -> Update r updateAllColumnNoPH = Monadic.updateAllColumnNoPH . runQueryA -- | Same as 'Monadic.insertValue''. -- Make 'Insert' from register arrow using configuration. -insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p +insertValue' :: (PersistableWidth p, TableDerivable r) => Config -> Register p r () -> Insert p insertValue' config = Monadic.insertValue' config . ($ ()) . runQueryA -- | Same as 'Monadic.insertValue'. -- Make 'Insert' from register arrow. -insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p +insertValue :: (PersistableWidth p, TableDerivable r) => Register p r () -> Insert p insertValue = Monadic.insertValue . ($ ()) . runQueryA -- | Same as 'Monadic.insertValueNoPH'. -- Make 'Insert' from register arrow. -insertValueNoPH :: TableDerivable r => Register r () -> Insert () +insertValueNoPH :: TableDerivable r => Register () r () -> Insert () insertValueNoPH = Monadic.insertValueNoPH . ($ ()) . runQueryA -- | Same as 'Monadic.delete''. -- Make 'Update' from restrict statement arrow using configuration. -delete' :: TableDerivable r => Config -> QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p +delete' :: (PersistableWidth p, TableDerivable r) => Config -> QueryA (ReadPlaceholders p Monadic.Restrict) (Record Flat r) () -> Delete p delete' config = Monadic.delete' config . runQueryA -- | Same as 'Monadic.delete'. -- Make 'Update' from restrict statement arrow. -delete :: TableDerivable r => QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p +delete :: (PersistableWidth p, TableDerivable r) => QueryA (ReadPlaceholders p Monadic.Restrict) (Record Flat r) () -> Delete p delete = Monadic.delete . runQueryA +-- | Same as 'Monadic.askPlaceholders'. +askPlaceholders :: Monad m => QueryA (ReadPlaceholders p m) () (Record PureOperand p) +askPlaceholders = queryA $ \() -> Monadic.askPlaceholders + -- | Same as 'Monadic.deleteNoPH'. -- Make 'Update' from restrict statement arrow. -deleteNoPH :: TableDerivable r => QueryA Monadic.Restrict (Record Flat r) () -> Delete () +deleteNoPH :: TableDerivable r => QueryA (ReadPlaceholders () Monadic.Restrict) (Record Flat r) () -> Delete () deleteNoPH = Monadic.deleteNoPH . runQueryA {-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-} -- | Same as 'Monadic.update''. -- Make 'Update' from assigning statement arrow using configuration. -derivedUpdate' :: TableDerivable r => Config -> QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p +derivedUpdate' :: (PersistableWidth p, TableDerivable r) => Config -> QueryA (Monadic.ReadPlaceholders p (MonadicAssigning.Assignings r Restrict)) (Record Flat r) () -> Update p derivedUpdate' = update' {-# DEPRECATED derivedUpdate "use `update` instead of this." #-} -- | Deprecated. -derivedUpdate :: TableDerivable r => QueryA (Monadic.Assignings r Restrict) (Record Flat r) (PlaceHolders p) -> Update p +derivedUpdate :: (PersistableWidth p, TableDerivable r) => QueryA (Monadic.ReadPlaceholders p (MonadicAssigning.Assignings r Restrict)) (Record Flat r) () -> Update p derivedUpdate = update {-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-} -- | Deprecated. -derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p +derivedInsertValue' :: (PersistableWidth p, TableDerivable r) => Config -> Register p r () -> Insert p derivedInsertValue' = insertValue' {-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-} -- | Deprecated. -derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p +derivedInsertValue :: (PersistableWidth p, TableDerivable r) => Register p r () -> Insert p derivedInsertValue = insertValue {-# DEPRECATED derivedDelete' "use `derivedDelete'` instead of this." #-} -- | Deprecated. -derivedDelete' :: TableDerivable r => Config -> QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p +derivedDelete' :: (PersistableWidth p, TableDerivable r) => Config -> QueryA (Monadic.ReadPlaceholders p Monadic.Restrict) (Record Flat r) () -> Delete p derivedDelete' = delete' {-# DEPRECATED derivedDelete "use `derivedDelete` instead of this." #-} -- | Deprecated. -derivedDelete :: TableDerivable r => QueryA Monadic.Restrict (Record Flat r) (PlaceHolders p) -> Delete p +derivedDelete :: (PersistableWidth p, TableDerivable r) => QueryA (Monadic.ReadPlaceholders p Monadic.Restrict) (Record Flat r) () -> Delete p derivedDelete = delete diff --git a/relational-query/src/Database/Relational/Derives.hs b/relational-query/src/Database/Relational/Derives.hs index f34878e8..fd320117 100644 --- a/relational-query/src/Database/Relational/Derives.hs +++ b/relational-query/src/Database/Relational/Derives.hs @@ -39,7 +39,7 @@ import Database.Relational.SqlSyntax (Record) import Database.Relational.Table (Table, TableDerivable) import Database.Relational.Pi (Pi, expandIndexes) import qualified Database.Relational.Record as Record -import Database.Relational.Projectable (placeholder, (.=.), (!)) +import Database.Relational.Projectable ((.=.), (!)) import Database.Relational.Monad.Class (wheres) import Database.Relational.Monad.BaseType (Relation, relationWidth) import Database.Relational.Relation @@ -56,10 +56,10 @@ specifiedKey :: PersistableWidth p => Pi a p -- ^ Projection path -> Relation () a -- ^ 'Relation' to add restriction. -> Relation p a -- ^ Result restricted 'Relation' -specifiedKey key rel = relation' $ do +specifiedKey key rel = relation' $ \ph -> do q <- query rel - (param, ()) <- placeholder (\ph -> wheres $ Record.wpi (relationWidth rel) q key .=. ph) - return (param, q) + wheres $ Record.wpi (relationWidth rel Record.pempty) q key .=. Record.toFlat ph + return q -- | Query restricted with specified unique key. uniqueSelect :: PersistableWidth p @@ -109,7 +109,8 @@ updateValuesWithKey :: ToSql q r updateValuesWithKey = unsafeUpdateValuesWithIndexes . expandIndexes -- | Typed 'KeyUpdate' using specified constraint key. -updateByConstraintKey :: Table r -- ^ 'Table' to update +updateByConstraintKey :: PersistableWidth p + => 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 diff --git a/relational-query/src/Database/Relational/Effect.hs b/relational-query/src/Database/Relational/Effect.hs index 4018e61a..c70a84a4 100644 --- a/relational-query/src/Database/Relational/Effect.hs +++ b/relational-query/src/Database/Relational/Effect.hs @@ -45,29 +45,30 @@ import Control.Applicative ((<$>)) import Control.Monad (void) import Data.Monoid ((<>)) import Data.List (unfoldr) -import Data.Functor.ProductIsomorphic (peRight) import Language.SQL.Keyword (Keyword(..)) import Database.Record.Persistable (PersistableWidth) import Database.Relational.Internal.Config (Config (chunksInsertSize, addModifyTableAliasAS), defaultConfig) -import Database.Relational.Internal.ContextType (Flat) -import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) +import Database.Relational.Internal.ContextType (Flat, PureOperand) +import Database.Relational.Internal.String (stringSQL, showStringSQL) import Database.Relational.SqlSyntax - (Record, composeWhere, composeSets, + (SQLWithPlaceholderOffsets', Record, composeWhere, composeSets, composeChunkValuesWithColumns, composeValuesListWithColumns, - Qualified, SubQuery, corrSubQueryTerm) + Qualified, SubQuery, corrSubQueryTerm, unQualify, + withPlaceholderOffsets, detachPlaceholderOffsets, collectPlaceholderOffsets,) 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.TupleInstances (fst', snd') import Database.Relational.ProjectableClass (LiteralSQL) -import Database.Relational.Projectable - (PlaceHolders, unitPH, pwPlaceholder, placeholder, (><), value, ) -import Database.Relational.Monad.BaseType (ConfigureQuery, qualifyQuery, askConfig) +import Database.Relational.Projectable ((!), value, ) +import Database.Relational.Monad.BaseType + (ConfigureQuery, qualifyQuery, askConfig, pwPlaceholders, defaultPlaceholders) import Database.Relational.Monad.Class (MonadQualify (..)) import Database.Relational.Monad.Trans.Assigning (assignings, (<-#)) import Database.Relational.Monad.Restrict (Restrict) @@ -76,154 +77,165 @@ import Database.Relational.Monad.Assign (Assign) import qualified Database.Relational.Monad.Assign as Assign import Database.Relational.Monad.Register (Register) import qualified Database.Relational.Monad.Register as Register +import Database.Relational.Monad.Trans.ReadPlaceholders + (ReadPlaceholders, runReadPlaceholders, readPlaceholders, askPlaceholders) -- helper function for UPDATE and DELETE -withQualified :: MonadQualify ConfigureQuery m => Table r -> (Record c r -> m a) -> m StringSQL +withQualified :: MonadQualify ConfigureQuery m => Table r -> (Record c r -> m a) -> m SQLWithPlaceholderOffsets' withQualified tbl q = do let qualTandR :: MonadQualify ConfigureQuery m => Table r -> m (Qualified SubQuery, Record c r) qualTandR tbl_ = liftQualify $ do qq <- qualifyQuery $ Table.toSubQuery tbl_ return (qq, Record.unsafeFromQualifiedSubQuery qq {- qualified record expression -}) (qq, r) <- qualTandR tbl - void $ q r -- placeholder info is not used + void $ q r addAS <- addModifyTableAliasAS <$> liftQualify askConfig - return $ corrSubQueryTerm addAS qq {- qualified table -} + return . withPlaceholderOffsets (collectPlaceholderOffsets $ unQualify qq) $ corrSubQueryTerm addAS qq {- qualified table -} -- | Restriction type with place-holder parameter 'p' and projected record type 'r'. -type Restriction p r = Record Flat r -> Restrict (PlaceHolders p) +type Restriction p r = Record Flat r -> ReadPlaceholders p Restrict () -- | Deprecated. -restriction :: (Record Flat r -> Restrict ()) -> Restriction () r -restriction = ((>> return unitPH) .) +restriction :: (Record Flat r -> ReadPlaceholders () Restrict ()) -> Restriction () r +restriction = id {-# DEPRECATED restriction "same as ((>> return unitPH) .)" #-} -- | Deprecated. -restriction' :: (Record Flat r -> Restrict (PlaceHolders p)) -> Restriction p r +restriction' :: (Record Flat r -> ReadPlaceholders p Restrict ()) -> Restriction p r restriction' = id {-# DEPRECATED restriction' "same as id" #-} -fromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> (StringSQL, StringSQL) -fromRestriction config tbl q = (qt, composeWhere rs) - where (qt, rs) = Restrict.extract (withQualified tbl q) config +fromRestriction :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> (SQLWithPlaceholderOffsets', SQLWithPlaceholderOffsets') +fromRestriction config tbl q = (qt, composeWhere <$> sequenceA rs) + where (qt, rs) = Restrict.extract (runReadPlaceholders (withQualified tbl q) defaultPlaceholders) config -- | SQL WHERE clause 'StringSQL' string from 'Restrict' computation. -sqlWhereFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL +sqlWhereFromRestriction :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> SQLWithPlaceholderOffsets' sqlWhereFromRestriction config tbl = snd . fromRestriction config tbl {-# DEPRECATED sqlWhereFromRestriction "low-level API, this API will be expired." #-} -- | DELETE statement with WHERE clause 'StringSQL' string from 'Restrict' computation. -deleteFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL -deleteFromRestriction config tbl r = - DELETE <> FROM <> uncurry (<>) (fromRestriction config tbl r) +deleteFromRestriction :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> SQLWithPlaceholderOffsets' +deleteFromRestriction config tbl rs = (\t r -> DELETE <> t <> r) <$> twp <*> rwp + where (twp, rwp) = fromRestriction config tbl rs -- | Show WHERE clause. -instance TableDerivable r => Show (Record Flat r -> Restrict (PlaceHolders p)) where - show = showStringSQL . snd . fromRestriction defaultConfig derivedTable +instance (PersistableWidth p, TableDerivable r) => Show (Record Flat r -> ReadPlaceholders p Restrict ()) where + show = showStringSQL . detachPlaceholderOffsets . snd . fromRestriction defaultConfig derivedTable -- | UpdateTarget type with place-holder parameter 'p' and projected record type 'r'. -type UpdateTarget p r = Record Flat r -> Assign r (PlaceHolders p) +type UpdateTarget p r = Record Flat r -> ReadPlaceholders p (Assign r) () -- | Deprecated. -updateTarget :: (Record Flat r -> Assign r ()) +updateTarget :: (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> UpdateTarget () r -updateTarget = ((>> return unitPH) .) +updateTarget = id {-# DEPRECATED updateTarget "old-style API. Use new-style Database.Relational.updateNoPH." #-} -- | Deprecated. -updateTarget' :: (Record Flat r -> Assign r (PlaceHolders p)) +updateTarget' :: (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> UpdateTarget p r updateTarget' = id {-# DEPRECATED updateTarget' "same as id" #-} -updateAllColumn :: PersistableWidth r - => (Record Flat r -> Restrict (PlaceHolders p)) - -> (Record Flat r -> Assign r (PlaceHolders (r, p))) +updateAllColumn :: (PersistableWidth r, PersistableWidth p) + => (Record Flat r -> ReadPlaceholders p Restrict ()) + -> (Record Flat r -> ReadPlaceholders (r, p) (Assign r) ()) updateAllColumn rs proj = do - (ph0, ()) <- placeholder (\ph -> id' <-# ph) - ph1 <- assignings $ rs proj - return $ ph0 >< ph1 + ph <- askPlaceholders + readPlaceholders $ do + id' <-# ph ! fst' + assignings $ runReadPlaceholders (rs proj) (ph ! snd') + return () -- | Lift 'Restrict' computation to 'Assign' computation. Assign target columns are all. liftTargetAllColumn :: PersistableWidth r - => (Record Flat r -> Restrict (PlaceHolders ())) - -> (Record Flat r -> Assign r (PlaceHolders r)) -liftTargetAllColumn rs = \proj -> fmap peRight $ updateAllColumn rs proj + => (Record Flat r -> ReadPlaceholders () Restrict ()) + -> (Record Flat r -> ReadPlaceholders r (Assign r) ()) +liftTargetAllColumn rs proj = do + ph <- askPlaceholders + readPlaceholders $ do + id' <-# ph + assignings $ runReadPlaceholders (rs proj) Record.pempty + return () {-# DEPRECATED liftTargetAllColumn "old-style API. use Database.Relational.updateAllColumnNoPH instead of this." #-} -- | Lift 'Restrict' computation to 'Assign' computation. Assign target columns are all. With placefolder type 'p'. -liftTargetAllColumn' :: PersistableWidth r - => (Record Flat r -> Restrict (PlaceHolders p)) - -> (Record Flat r -> Assign r (PlaceHolders (r, p))) +liftTargetAllColumn' :: (PersistableWidth r, PersistableWidth p) + => (Record Flat r -> ReadPlaceholders p Restrict ()) + -> (Record Flat r -> ReadPlaceholders (r, p) (Assign r) ()) liftTargetAllColumn' rs = updateAllColumn rs -- | Deprecated. updateTargetAllColumn :: PersistableWidth r - => (Record Flat r -> Restrict ()) - -> (Record Flat r -> Assign r (PlaceHolders r)) + => (Record Flat r -> ReadPlaceholders () Restrict ()) + -> (Record Flat r -> ReadPlaceholders r (Assign r) ()) updateTargetAllColumn = liftTargetAllColumn . restriction {-# DEPRECATED updateTargetAllColumn "Use Database.Relational.updateAllColumnNoPH instead of this." #-} -- | Deprecated. -updateTargetAllColumn' :: PersistableWidth r - => (Record Flat r -> Restrict (PlaceHolders p)) - -> (Record Flat r -> Assign r (PlaceHolders (r, p))) +updateTargetAllColumn' :: (PersistableWidth r, PersistableWidth p) + => (Record Flat r -> ReadPlaceholders p Restrict ()) + -> (Record Flat r -> ReadPlaceholders (r, p) (Assign r) ()) updateTargetAllColumn' = liftTargetAllColumn' {-# DEPRECATED updateTargetAllColumn' "Use Database.Relational.updateAllColumn instead of this." #-} -fromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> (StringSQL, StringSQL) -fromUpdateTarget config tbl q = (qt, composeSets (asR tbl) <> composeWhere rs) - where ((qt, asR), rs) = Assign.extract (withQualified tbl q) config +fromUpdateTarget :: PersistableWidth p + => Config + -> Table r + -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) + -> (SQLWithPlaceholderOffsets', SQLWithPlaceholderOffsets') +fromUpdateTarget config tbl q = (qt, (<>) <$> composeSets (asR tbl) <*> (composeWhere <$> sequenceA rs)) + where ((qt, asR), rs) = Assign.extract (runReadPlaceholders (withQualified tbl q) defaultPlaceholders) config -- | SQL SET clause and WHERE clause 'StringSQL' string from 'Assign' computation. -sqlFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL +sqlFromUpdateTarget :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> SQLWithPlaceholderOffsets' sqlFromUpdateTarget config tbl = snd . fromUpdateTarget config tbl {-# DEPRECATED sqlFromUpdateTarget "low-level API, this API will be expired." #-} -- | UPDATE statement with SET clause and WHERE clause 'StringSQL' string from 'Assign' computation. -updateFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL -updateFromUpdateTarget config tbl ut = - UPDATE <> uncurry (<>) (fromUpdateTarget config tbl ut) +updateFromUpdateTarget :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> SQLWithPlaceholderOffsets' +updateFromUpdateTarget config tbl ut = (\t r -> UPDATE <> t <> r) <$> twp <*> rwp + where (twp, rwp) = fromUpdateTarget config tbl ut -- | Show Set clause and WHERE clause. -instance TableDerivable r => Show (Record Flat r -> Assign r (PlaceHolders p)) where - show = showStringSQL . snd . fromUpdateTarget defaultConfig derivedTable +instance (PersistableWidth p, TableDerivable r) => Show (Record Flat r -> ReadPlaceholders p (Assign r) ()) where + show = showStringSQL . detachPlaceholderOffsets . sqlFromUpdateTarget defaultConfig derivedTable -- | InsertTarget type with place-holder parameter 'p' and projected record type 'r'. -newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p)) +newtype InsertTarget p r = InsertTarget (ReadPlaceholders p (Register r) ()) -- | Finalize 'Register' monad and generate 'InsertTarget'. -insertTarget :: Register r () +insertTarget :: ReadPlaceholders () (Register r) () -> InsertTarget () r -insertTarget = InsertTarget . (>> return unitPH) +insertTarget = InsertTarget {-# DEPRECATED insertTarget "old-style API. Use new-style Database.Relational.insertValueNoPH ." #-} -- | Finalize 'Register' monad and generate 'InsertTarget' with place-holder parameter 'p'. -insertTarget' :: Register r (PlaceHolders p) +insertTarget' :: ReadPlaceholders p (Register r) () -> 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' + -> ReadPlaceholders r' (Register r) () +piRegister pi' = readPlaceholders (pi' <-# pwPlaceholders (Pi.width' pi')) sqlChunkFromInsertTarget' :: Config -> Int + -> Record PureOperand p -> Table r -> InsertTarget p r - -> StringSQL -sqlChunkFromInsertTarget' config sz tbl (InsertTarget q) = - INSERT <> INTO <> stringSQL (Table.name tbl) <> composeChunkValuesWithColumns sz (asR tbl) + -> SQLWithPlaceholderOffsets' +sqlChunkFromInsertTarget' config sz phs tbl (InsertTarget q) = + (\cs -> INSERT <> INTO <> stringSQL (Table.name tbl) <> cs) <$> composeChunkValuesWithColumns sz (asR tbl) where - (_ph, asR) = Register.extract q config + (_, asR) = Register.extract (runReadPlaceholders q phs) config countChunks :: Config -> Table r @@ -236,16 +248,17 @@ countChunks config tbl = -- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget' sqlChunkFromInsertTarget :: Config + -> Record PureOperand p -> Table r -> InsertTarget p r - -> (StringSQL, Int) -sqlChunkFromInsertTarget config tbl it = - (sqlChunkFromInsertTarget' config n tbl it, n) + -> (SQLWithPlaceholderOffsets', Int) +sqlChunkFromInsertTarget config phs tbl it = + (sqlChunkFromInsertTarget' config n phs tbl it, n) where n = countChunks config tbl -- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget' -sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL +sqlFromInsertTarget :: Config -> Record PureOperand p -> Table r -> InsertTarget p r -> SQLWithPlaceholderOffsets' sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1 -- | Make 'StringSQL' strings of SQL INSERT strings from records list @@ -254,18 +267,19 @@ sqlChunksFromRecordList :: LiteralSQL r' -> Table r -> Pi r r' -> [r'] - -> [StringSQL] + -> [SQLWithPlaceholderOffsets'] sqlChunksFromRecordList config tbl pi' xs = - [ INSERT <> INTO <> stringSQL (Table.name tbl) <> - composeValuesListWithColumns - [ tf tbl - | r <- rs - , let ((), tf) = Register.extract (pi' <-# value r) config - ] + [ (\cs -> INSERT <> INTO <> stringSQL (Table.name tbl) <> cs) + <$> + composeValuesListWithColumns + [ tf tbl + | r <- rs + , let ((), tf) = Register.extract (pi' <-# Record.toFlat (value r)) config + ] | rs <- unfoldr step xs ] where n = countChunks config tbl step ys | null ys = Nothing - | otherwise = Just $ splitAt n ys + | otherwise = Just $ splitAt n ys diff --git a/relational-query/src/Database/Relational/Internal/ContextType.hs b/relational-query/src/Database/Relational/Internal/ContextType.hs index 9516a812..dacc0b8d 100644 --- a/relational-query/src/Database/Relational/Internal/ContextType.hs +++ b/relational-query/src/Database/Relational/Internal/ContextType.hs @@ -11,7 +11,7 @@ -- -- This module defines query context tag types. module Database.Relational.Internal.ContextType ( - Flat, Aggregated, Exists, OverWindow, + Flat, Aggregated, Exists, OverWindow, PureOperand, Set, SetList, Power, ) where @@ -28,6 +28,9 @@ data Exists -- | Type tag for window function building data OverWindow +-- | Type tag for records all of whom values are placeholders (denoted as "?" in the generated SQL) or literal value. +data PureOperand + -- | Type tag for normal aggregatings set data Set diff --git a/relational-query/src/Database/Relational/Monad/Aggregate.hs b/relational-query/src/Database/Relational/Monad/Aggregate.hs index 9d764bd8..55c4c9ef 100644 --- a/relational-query/src/Database/Relational/Monad/Aggregate.hs +++ b/relational-query/src/Database/Relational/Monad/Aggregate.hs @@ -34,13 +34,13 @@ import qualified Language.SQL.Keyword as SQL import Database.Relational.Internal.ContextType (Flat, Aggregated, OverWindow) import Database.Relational.SqlSyntax - (Duplication, Record, SubQuery, Predicate, JoinProduct, + (Duplication, Record, SubQuery, JoinProduct, OrderingTerm, composeOrderBy, aggregatedSubQuery, - AggregateColumnRef, AggregateElem, composePartitionBy, ) + AggregateColumnRef, AggregateElem, composePartitionBy, WithPlaceholderOffsets, ) import qualified Database.Relational.SqlSyntax as Syntax import qualified Database.Relational.Record as Record -import Database.Relational.Projectable (PlaceHolders, SqlContext) +import Database.Relational.Projectable (SqlContext) import Database.Relational.Monad.Class (MonadRestrict(..)) import Database.Relational.Monad.Trans.Restricting (Restrictings, restrictings, extractRestrict) @@ -55,8 +55,8 @@ 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 +-- | Aggregated query type. 'AggregatedQuery' p r == 'QueryAggregate' ('Record' 'Aggregated' r). +type AggregatedQuery r = OrderedQuery Aggregated (Restrictings Aggregated (AggregatingSetT QueryCore)) r -- | Partition monad type for partition-by clause. type Window c = Orderings c (PartitioningSet c) @@ -65,28 +65,29 @@ type Window c = Orderings c (PartitioningSet c) 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 :: AggregatedQuery r + -> ConfigureQuery (((((((Record Aggregated r), + WithPlaceholderOffsets [OrderingTerm]), + [WithPlaceholderOffsets Syntax.Tuple]), + WithPlaceholderOffsets [AggregateElem]), + [WithPlaceholderOffsets Syntax.Tuple]), + WithPlaceholderOffsets JoinProduct), Duplication) extract = extractCore . extractAggregateTerms . extractRestrict . extractOrderingTerms -- | Run 'AggregatedQuery' to get SQL with 'ConfigureQuery' computation. -toSQL :: AggregatedQuery p r -- ^ 'AggregatedQuery' to run +toSQL :: AggregatedQuery 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 +toSubQuery :: AggregatedQuery r -- ^ 'AggregatedQuery' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'ConfigureQuery' computation toSubQuery q = do - (((((((_ph, pj), ot), grs), ag), rs), pd), da) <- extract q + ((((((pj, ot), grs), ag), rs), pd), da) <- extract q c <- askConfig - return $ aggregatedSubQuery c (Record.untype pj) da pd rs ag grs ot + return $ aggregatedSubQuery c (Syntax.untypeRecordWithPlaceholderOffsets pj) da pd rs ag grs ot -extractWindow :: Window c a -> ((a, [OrderingTerm]), [AggregateColumnRef]) +extractWindow :: Window c a -> ((a, WithPlaceholderOffsets [OrderingTerm]), WithPlaceholderOffsets [AggregateColumnRef]) extractWindow = runIdentity . extractAggregateTerms . extractOrderingTerms -- | Operator to make record of window function result using built 'Window' monad. @@ -94,10 +95,11 @@ 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 +wp `over` win = Record.unsafeFromSqlTerms (f <$> ptPhs <*> otPhs) where + f pt ot = + [ c <> OVER <> SQL.paren (composePartitionBy pt <> composeOrderBy ot) + | c <- Record.columns wp + ] + (((), otPhs), ptPhs) = extractWindow win infix 8 `over` diff --git a/relational-query/src/Database/Relational/Monad/Assign.hs b/relational-query/src/Database/Relational/Monad/Assign.hs index c64a71dc..b4c4c3e6 100644 --- a/relational-query/src/Database/Relational/Monad/Assign.hs +++ b/relational-query/src/Database/Relational/Monad/Assign.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Database.Relational.Monad.Assign @@ -16,17 +17,23 @@ module Database.Relational.Monad.Assign ( -- * Monad to restrict target records with assignment. Assign, AssignStatement, extract, + + -- * API of context with assignments + assignTo, (<-#), ) where import Database.Relational.Internal.Config (Config) import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.Projectable.Unsafe (ResultContext) import Database.Relational.SqlSyntax - (Predicate, Record, Assignment) + (Record, Assignment, WithPlaceholderOffsets, Tuple) 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) +import Database.Relational.Monad.Trans.ReadPlaceholders (ReadPlaceholders, readPlaceholders) +import Database.Relational.Monad.Trans.Assigning (Assignings, AssignTarget, extractAssignments) +import qualified Database.Relational.Monad.Trans.Assigning as Trans -- | Target update monad type used from update statement and merge statement. @@ -36,8 +43,15 @@ type Assign r = Assignings r Restrict -- 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 +type AssignStatement p r a = Record Flat r -> ReadPlaceholders p (Assign r) a -- | Run 'Assign'. -extract :: Assign r a -> Config -> ((a, Table r -> [Assignment]), [Predicate Flat]) +extract :: Assign r a -> Config -> ((a, Table r -> WithPlaceholderOffsets [Assignment]), [WithPlaceholderOffsets Tuple]) extract = Restrict.extract . extractAssignments + + +assignTo :: (Monad m, ResultContext c Flat ~ Flat) => Record c v -> AssignTarget r v -> ReadPlaceholders p (Assignings r m) () +assignTo r = readPlaceholders . Trans.assignTo r + +(<-#) :: (Monad m, ResultContext c Flat ~ Flat) => AssignTarget r v -> Record c v -> ReadPlaceholders p (Assignings r m) () +(<-#) = flip assignTo diff --git a/relational-query/src/Database/Relational/Monad/BaseType.hs b/relational-query/src/Database/Relational/Monad/BaseType.hs index de607c88..8e7e3107 100644 --- a/relational-query/src/Database/Relational/Monad/BaseType.hs +++ b/relational-query/src/Database/Relational/Monad/BaseType.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- Module : Database.Relational.Monad.BaseType -- Copyright : 2015-2017 Kei Hibino @@ -16,22 +18,32 @@ module Database.Relational.Monad.BaseType -- * Relation type Relation, unsafeTypeRelation, untypeRelation, relationWidth, + -- * Generate a record representing placeholders + defaultPlaceholders, pwPlaceholders, + dump, sqlFromRelationWith, sqlFromRelation, - - rightPh, leftPh, ) where import Data.Functor.Identity (Identity, runIdentity) -import Control.Applicative ((<$>)) +import Data.DList (fromList) +import Control.Arrow ((&&&)) -import Database.Record.Persistable (PersistableRecordWidth, unsafePersistableRecordWidth) +import Database.Record.Persistable + (PersistableRecordWidth, PersistableWidth, persistableWidth, unsafePersistableRecordWidth, runPersistableRecordWidth) +import Database.Relational.Projectable.Unsafe (unsafeProjectSqlTermsWithPlaceholders) +import Database.Relational.Projectable.Instances () -import Database.Relational.Internal.String (StringSQL, showStringSQL) +import Database.Relational.Internal.String (showStringSQL) import Database.Relational.Internal.Config (Config, defaultConfig) -import Database.Relational.SqlSyntax (Qualified, SubQuery, showSQL, width) +import Database.Relational.Internal.ContextType (PureOperand) +import Database.Relational.SqlSyntax + (Qualified, SubQuery, Record, SQLWithPlaceholderOffsets', + showSQL, width, collectPlaceholderOffsets, detachPlaceholderOffsets, withPlaceholderOffsets) import qualified Database.Relational.Monad.Trans.Qualify as Qualify +import Database.Relational.Monad.Trans.ReadPlaceholders.Type + (ReadPlaceholders, runReadPlaceholders) import Database.Relational.Monad.Trans.Qualify (Qualify, qualify, evalQualifyPrime) import Database.Relational.Monad.Trans.Config (QueryConfig, runQueryConfig, askQueryConfig) @@ -52,44 +64,50 @@ askConfig = qualify askQueryConfig -- | Relation type with place-holder parameter 'p' and query result type 'r'. -newtype Relation p r = SubQuery (ConfigureQuery SubQuery) +newtype Relation p r = SubQuery (ReadPlaceholders p ConfigureQuery SubQuery) -- | Unsafely type qualified subquery into record typed relation type. -unsafeTypeRelation :: ConfigureQuery SubQuery -> Relation p r +unsafeTypeRelation :: ReadPlaceholders p ConfigureQuery SubQuery -> Relation p r unsafeTypeRelation = SubQuery -- | Sub-query Qualify monad from relation. -untypeRelation :: Relation p r -> ConfigureQuery SubQuery -untypeRelation (SubQuery qsub) = qsub +untypeRelation :: Relation p r -> Record PureOperand p -> ConfigureQuery SubQuery +untypeRelation (SubQuery qsub) = runReadPlaceholders 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 +relationWidth :: Relation p r -> Record PureOperand p -> PersistableRecordWidth r +relationWidth rel phs = + unsafePersistableRecordWidth + . width + . (`configureQuery` defaultConfig) --- Assume that width is independent from Config structure + $ (untypeRelation rel phs) -- | Generate SQL string from 'Relation' with configuration. -sqlFromRelationWith :: Relation p r -> Config -> StringSQL -sqlFromRelationWith = configureQuery . (showSQL <$>) . untypeRelation +sqlFromRelationWith :: Relation p r -> Record PureOperand p -> Config -> SQLWithPlaceholderOffsets' +sqlFromRelationWith r p c = + uncurry withPlaceholderOffsets + . (collectPlaceholderOffsets &&& showSQL) + . (`configureQuery` c) + $ untypeRelation r p -- | SQL string from 'Relation'. -sqlFromRelation :: Relation p r -> StringSQL -sqlFromRelation = (`sqlFromRelationWith` defaultConfig) +sqlFromRelation :: Relation p r -> Record PureOperand p -> SQLWithPlaceholderOffsets' +sqlFromRelation r p = sqlFromRelationWith r p defaultConfig -- | Dump internal structure tree. -dump :: Relation p r -> String -dump = show . (`configureQuery` defaultConfig) . untypeRelation - -instance Show (Relation p r) where - show = showStringSQL . sqlFromRelation +dump :: PersistableWidth p => Relation p r -> String +dump = show . (`configureQuery` defaultConfig) . (`untypeRelation` defaultPlaceholders) + +instance PersistableWidth p => Show (Relation p r) where + show = showStringSQL . detachPlaceholderOffsets . (`sqlFromRelation` defaultPlaceholders) + +defaultPlaceholders :: PersistableWidth t => Record PureOperand t +defaultPlaceholders = pwPlaceholders persistableWidth + +pwPlaceholders :: PersistableRecordWidth a + -> Record PureOperand a +pwPlaceholders pw = + unsafeProjectSqlTermsWithPlaceholders . withPlaceholderOffsets phs $ replicate w "?" + where + w = runPersistableRecordWidth pw + phs = fromList [0 .. (w - 1)] diff --git a/relational-query/src/Database/Relational/Monad/Class.hs b/relational-query/src/Database/Relational/Monad/Class.hs index b4c5e792..433d246f 100644 --- a/relational-query/src/Database/Relational/Monad/Class.hs +++ b/relational-query/src/Database/Relational/Monad/Class.hs @@ -21,11 +21,10 @@ module Database.Relational.Monad.Class on, wheres, having, ) where -import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Relational.Internal.ContextType (Flat, Aggregated, PureOperand) import Database.Relational.SqlSyntax - (Duplication (..), Predicate, Record, AggregateKey) + ( Duplication (..) , Predicate, Record, AggregateKey, ) -import Database.Relational.Projectable (PlaceHolders) import Database.Relational.Monad.BaseType (ConfigureQuery, Relation) @@ -44,11 +43,13 @@ class (Functor m, Monad m, MonadQualify ConfigureQuery m) => MonadQuery m where -> 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) + query' :: Record PureOperand p + -> Relation p r + -> m (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)) + queryMaybe' :: Record PureOperand p + -> Relation p r + -> m (Record Flat (Maybe r)) -- | Lift interface from base qualify monad. class (Functor q, Monad q, Functor m, Monad m) => MonadQualify q m where @@ -65,8 +66,8 @@ class MonadQuery m => MonadAggregate m where 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 + 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 diff --git a/relational-query/src/Database/Relational/Monad/Register.hs b/relational-query/src/Database/Relational/Monad/Register.hs index a0da89d0..50fbdd65 100644 --- a/relational-query/src/Database/Relational/Monad/Register.hs +++ b/relational-query/src/Database/Relational/Monad/Register.hs @@ -16,7 +16,7 @@ module Database.Relational.Monad.Register ( ) where import Database.Relational.Internal.Config (Config) -import Database.Relational.SqlSyntax (Assignment) +import Database.Relational.SqlSyntax (Assignment, WithPlaceholderOffsets) import Database.Relational.Table (Table) import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery) @@ -27,5 +27,5 @@ import Database.Relational.Monad.Trans.Assigning (Assignings, extractAssignments type Register r = Assignings r ConfigureQuery -- | Run 'InsertStatement'. -extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> [Assignment]) +extract :: Assignings r ConfigureQuery a -> Config -> (a, Table r -> WithPlaceholderOffsets [Assignment]) extract = configureQuery . extractAssignments diff --git a/relational-query/src/Database/Relational/Monad/Restrict.hs b/relational-query/src/Database/Relational/Monad/Restrict.hs index 090c56e0..1e1a2006 100644 --- a/relational-query/src/Database/Relational/Monad/Restrict.hs +++ b/relational-query/src/Database/Relational/Monad/Restrict.hs @@ -20,10 +20,11 @@ module Database.Relational.Monad.Restrict ( import Database.Relational.Internal.ContextType (Flat) import Database.Relational.Internal.Config (Config) -import Database.Relational.SqlSyntax (Predicate, Record) +import Database.Relational.SqlSyntax (Tuple, Record, WithPlaceholderOffsets) import Database.Relational.Monad.Trans.Restricting (Restrictings, extractRestrict) +import Database.Relational.Monad.Trans.ReadPlaceholders (ReadPlaceholders,) import Database.Relational.Monad.BaseType (ConfigureQuery, configureQuery) @@ -33,8 +34,8 @@ 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 +type RestrictedStatement p r a = Record Flat r -> ReadPlaceholders p Restrict a -- | Run 'Restrict' to get 'QueryRestriction'. -extract :: Restrict a -> Config -> (a, [Predicate Flat]) +extract :: Restrict a -> Config -> (a, [WithPlaceholderOffsets Tuple]) extract = configureQuery . extractRestrict diff --git a/relational-query/src/Database/Relational/Monad/Simple.hs b/relational-query/src/Database/Relational/Monad/Simple.hs index cd824df9..78e0a563 100644 --- a/relational-query/src/Database/Relational/Monad/Simple.hs +++ b/relational-query/src/Database/Relational/Monad/Simple.hs @@ -24,44 +24,43 @@ module Database.Relational.Monad.Simple ( import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax - (Duplication, OrderingTerm, JoinProduct, Predicate, Record, + (Duplication, OrderingTerm, JoinProduct, Tuple, 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 +-- | Simple (not-aggregated) query type. 'SimpleQuery'' r == 'QuerySimple' ('Record' Flat r). +type SimpleQuery r = OrderedQuery Flat QueryCore 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 :: SimpleQuery r + -> ConfigureQuery (((((Record Flat r), + Syntax.WithPlaceholderOffsets [OrderingTerm]), [Syntax.WithPlaceholderOffsets Tuple]), + Syntax.WithPlaceholderOffsets JoinProduct), Duplication) extract = extractCore . extractOrderingTerms -- | Run 'SimpleQuery' to get SQL string with 'Qualify' computation. -toSQL :: SimpleQuery p r -- ^ 'SimpleQuery' to run +toSQL :: SimpleQuery 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 +toSubQuery :: SimpleQuery r -- ^ 'SimpleQuery'' to run -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation toSubQuery q = do - (((((_ph, pj), ot), rs), pd), da) <- extract q + ((((pj, ot), rs), pd), da) <- extract q c <- askConfig - return $ flatSubQuery c (Record.untype pj) da pd rs ot + return $ flatSubQuery c (Syntax.untypeRecordWithPlaceholderOffsets pj) da pd rs ot diff --git a/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs b/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs index f043e3d1..7d137211 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs @@ -30,19 +30,23 @@ module Database.Relational.Monad.Trans.Aggregating import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) -import Control.Applicative (Applicative, pure, (<$>)) +import Control.Applicative (Applicative, (<$>)) import Control.Arrow (second) -import Data.DList (DList, toList) +import Data.DList (DList, fromList, toList, singleton) import Data.Functor.Identity (Identity (runIdentity)) import Database.Relational.Internal.ContextType (Flat, Aggregated, Set, Power, SetList) import Database.Relational.SqlSyntax - (Record, untypeRecord, + (Record, AggregateColumnRef, AggregateElem, aggregateColumnRef, AggregateSet, aggregateGroupingSet, AggregateBitKey, aggregatePowerKey, aggregateRollup, aggregateCube, aggregateSets, - AggregateKey, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey) + AggregateKey, aggregateKeyRecord, aggregateKeyElement, unsafeAggregateKey, + WithPlaceholderOffsetsT (WithPlaceholderOffsetsT), WithPlaceholderOffsets, + runWithPlaceholderOffsetsT, withPlaceholderOffsets, appendPlaceholderOffsets, + tupleFromPlaceholderOffsets, record, + untypeRecord, untypeRecordWithPlaceholderOffsets, emptyPlaceholderOffsetsOfRecord,) import qualified Database.Relational.Record as Record import Database.Relational.Monad.Class @@ -54,7 +58,14 @@ import Database.Relational.Monad.Class -- 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) + Aggregatings { unAggregatings :: (WithPlaceholderOffsetsT (AggregatingsBase ac at m) a) } + deriving (Monad, Functor, Applicative) + +instance MonadTrans (Aggregatings ac at) where + lift = Aggregatings . lift . lift + +newtype AggregatingsBase ac at m a = + AggregatingsBase { unAggregatingsBase :: (WriterT (DList at) m a) } deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Aggregatings'. @@ -62,16 +73,19 @@ aggregatings :: Monad m => m a -> Aggregatings ac at m a aggregatings = lift -- | Context type building one grouping set. -type AggregatingSetT = Aggregatings Set AggregateElem +type AggregatingSetT = Aggregatings Set AggregateElem + +-- | Context type building one grouping set. +type AggregatingSetBaseT = AggregatingsBase Set AggregateElem -- | Context type building grouping sets list. -type AggregatingSetListT = Aggregatings SetList AggregateSet +type AggregatingSetListT = AggregatingsBase SetList AggregateSet -- | Context type building power group set. -type AggregatingPowerSetT = Aggregatings Power AggregateBitKey +type AggregatingPowerSetT = AggregatingsBase Power AggregateBitKey -- | Context type building partition keys set. -type PartitioningSetT c = Aggregatings c AggregateColumnRef +type PartitioningSetT c = Aggregatings c AggregateColumnRef -- | Aggregated 'MonadRestrict'. instance MonadRestrict c m => MonadRestrict c (AggregatingSetT m) where @@ -85,13 +99,16 @@ instance MonadQualify q m => MonadQualify q (AggregatingSetT m) where instance MonadQuery m => MonadQuery (AggregatingSetT m) where setDuplication = aggregatings . setDuplication restrictJoin = aggregatings . restrictJoin - query' = aggregatings . query' - queryMaybe' = aggregatings . queryMaybe' + query' ph = aggregatings . query' ph + queryMaybe' ph = aggregatings . queryMaybe' ph + +unsafeAggregateWithTerm :: Monad m => at -> AggregatingsBase ac at m () +unsafeAggregateWithTerm = AggregatingsBase . tell . singleton -unsafeAggregateWithTerm :: Monad m => at -> Aggregatings ac at m () -unsafeAggregateWithTerm = Aggregatings . tell . pure +unsafeAggregateWithTerms :: Monad m => [at] -> AggregatingsBase ac at m () +unsafeAggregateWithTerms = AggregatingsBase . tell . fromList -aggregateKey :: Monad m => AggregateKey a -> Aggregatings ac AggregateElem m a +aggregateKey :: Monad m => AggregateKey a -> AggregatingsBase ac AggregateElem m a aggregateKey k = do unsafeAggregateWithTerm $ aggregateKeyElement k return $ aggregateKeyRecord k @@ -99,23 +116,39 @@ aggregateKey k = do -- | Aggregated query instance. instance MonadQuery m => MonadAggregate (AggregatingSetT m) where groupBy p = do - mapM_ unsafeAggregateWithTerm [ aggregateColumnRef col | col <- untypeRecord p] - return $ Record.unsafeToAggregated p - groupBy' = aggregateKey + let (ts, phs) = tupleFromPlaceholderOffsets $ untypeRecordWithPlaceholderOffsets p + Aggregatings $ do + lift . unsafeAggregateWithTerms $ map aggregateColumnRef ts + appendPlaceholderOffsets phs + return . emptyPlaceholderOffsetsOfRecord $ Record.unsafeToAggregated p + groupBy' kr = do + r <- Aggregatings . lift $ aggregateKey kr + let (ts, phs) = tupleFromPlaceholderOffsets $ untypeRecordWithPlaceholderOffsets r + Aggregatings $ appendPlaceholderOffsets phs + return $ record mempty ts -- | Partition clause instance instance Monad m => MonadPartition c (PartitioningSetT c m) where - partitionBy = mapM_ unsafeAggregateWithTerm . untypeRecord + partitionBy r = Aggregatings $ do + lift $ unsafeAggregateWithTerms ts + appendPlaceholderOffsets phs + where + (ts, phs) = tupleFromPlaceholderOffsets $ untypeRecordWithPlaceholderOffsets r -- | 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 +extractAggregateTerms :: (Monad m, Functor m) => Aggregatings ac at m a -> m (a, WithPlaceholderOffsets [at]) +extractAggregateTerms = fmap f . runWriterT . unAggregatingsBase . runWithPlaceholderOffsetsT . unAggregatings + where + f ((x, phs), ats) = (x, withPlaceholderOffsets phs $ toList ats) + +extractAggregateTermsBase :: (Monad m, Functor m) => AggregatingsBase ac at m a -> m (a, [at]) +extractAggregateTermsBase (AggregatingsBase ac) = second toList <$> runWriterT ac -extractTermList :: Aggregatings ac at Identity a -> (a, [at]) -extractTermList = runIdentity . extractAggregateTerms +extractTermList :: AggregatingsBase ac at Identity a -> (a, [at]) +extractTermList = runIdentity . extractAggregateTermsBase -- | Context monad type to build single grouping set. -type AggregatingSet = AggregatingSetT Identity +type AggregatingSet = AggregatingSetBaseT Identity -- | Context monad type to build grouping power set. type AggregatingPowerSet = AggregatingPowerSetT Identity @@ -155,7 +188,7 @@ bkey p = do finalizePower :: ([AggregateBitKey] -> AggregateElem) -> AggregatingPowerSet a -> AggregateKey a -finalizePower finalize pow = unsafeAggregateKey . second finalize . extractTermList $ pow +finalizePower finalize pow = unsafeAggregateKey . second finalize $ extractTermList pow -- | Finalize grouping power set as rollup power set. rollup :: AggregatingPowerSet a -> AggregateKey a diff --git a/relational-query/src/Database/Relational/Monad/Trans/Assigning.hs b/relational-query/src/Database/Relational/Monad/Trans/Assigning.hs index 26761d35..d25dd666 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Assigning.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Assigning.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Database.Relational.Monad.Trans.Assigning @@ -32,7 +34,10 @@ import Data.Monoid (mconcat) import Data.DList (DList, toList) import Database.Relational.Internal.ContextType (Flat) -import Database.Relational.SqlSyntax (Record, Assignment) +import Database.Relational.Internal.String (StringSQL) +import Database.Relational.SqlSyntax (Record, Assignment, WithPlaceholderOffsets) +import Database.Relational.Projectable.Unsafe (ResultContext) +import Database.Relational.Projectable.Instances () import Database.Relational.Pi (Pi) import Database.Relational.Table (Table, recordWidth) @@ -43,7 +48,7 @@ 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) + Assignings (WriterT (Table r -> WithPlaceholderOffsets (DList Assignment)) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Assignings' @@ -65,14 +70,19 @@ 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 :: forall c v m r. (Monad m, ResultContext c Flat ~ Flat) => Record c v -> AssignTarget r v -> Assignings r m () assignTo vp target = Assignings . tell - $ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where + $ \t -> mconcat . zipWith (curry pure) (leftsR t) <$> rights where + + -- NOTE: While 'rights' should be 'WithPlaceholders' [StringSQL], 'leftsR' doesn't have to be so. + -- Because Record created from AssignTarget doesn't refer any placeholders. + leftsR :: Table r -> [StringSQL] leftsR = Record.columns . targetRecord target - rights = Record.columns vp + rights :: WithPlaceholderOffsets [StringSQL] + rights = Record.columnsWithPlaceholders vp -- | Add and assginment. -(<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m () +(<-#) :: (Monad m, ResultContext c Flat ~ Flat) => AssignTarget r v -> Record c v -> Assignings r m () (<-#) = flip assignTo infix 4 <-# @@ -80,5 +90,5 @@ infix 4 <-# -- | Run 'Assignings' to get ['Assignment'] extractAssignments :: (Monad m, Functor m) => Assignings r m a - -> m (a, Table r -> [Assignment]) -extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac + -> m (a, Table r -> WithPlaceholderOffsets [Assignment]) +extractAssignments (Assignings ac) = second (fmap toList .) <$> runWriterT ac diff --git a/relational-query/src/Database/Relational/Monad/Trans/Join.hs b/relational-query/src/Database/Relational/Monad/Trans/Join.hs index fc1ae31e..44575c08 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Join.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Join.hs @@ -33,24 +33,26 @@ import Control.Arrow (second, (***)) import Data.Maybe (fromMaybe) import Data.Monoid (Last (Last, getLast)) -import Database.Relational.Internal.ContextType (Flat) +import Database.Relational.Internal.ContextType (Flat, PureOperand) import Database.Relational.Internal.Config (addQueryTableAliasAS) import Database.Relational.SqlSyntax (Duplication (All), NodeAttr (Just', Maybe), Predicate, Record, - SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, ) + SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, + PlaceholderOffsets, WithPlaceholderOffsets, + mapWithPlaceholderOffsets, attachEmptyPlaceholderOffsets, + placeholderOffsetsOfRecord, emptyPlaceholderOffsetsOfRecord, untypeRecord) import Database.Relational.Monad.Class (liftQualify) import Database.Relational.Monad.Trans.JoinState (JoinContext, primeJoinContext, updateProduct, joinProduct) import qualified Database.Relational.Record as Record -import Database.Relational.Projectable (PlaceHolders, unsafeAddPlaceHolders) import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig, qualifyQuery, Relation, untypeRelation) import Database.Relational.Monad.Class (MonadQualify (..), MonadQuery (..)) -- | 'StateT' type to accumulate join product context. newtype QueryJoin m a = - QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a) + QueryJoin (StateT (WithPlaceholderOffsets JoinContext) (WriterT (Last Duplication) m) a) deriving (Monad, Functor, Applicative) instance MonadTrans QueryJoin where @@ -61,14 +63,15 @@ 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 +updateContext :: Monad m => PlaceholderOffsets -> (JoinContext -> JoinContext) -> QueryJoin m () +updateContext phs f = + QueryJoin $ modify (mapWithPlaceholderOffsets (f *** (phs <>))) -- | Add last join product restriction. updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m () -updateJoinRestriction e = updateContext (updateProduct d) where +updateJoinRestriction e = updateContext (placeholderOffsetsOfRecord e) (updateProduct d) where d Nothing = error "on: Product is empty! Restrict target product is not found!" - d (Just pt) = restrictProduct pt e + d (Just pt) = restrictProduct pt $ untypeRecord e instance MonadQualify q m => MonadQualify q (QueryJoin m) where liftQualify = join' . liftQualify @@ -78,9 +81,8 @@ 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) + queryMaybe' phs = + fmap Record.just . queryWithAttr Maybe phs -- | Unsafely join sub-query with this query. unsafeSubQueryWithAttr :: MonadQualify ConfigureQuery q @@ -88,22 +90,23 @@ unsafeSubQueryWithAttr :: MonadQualify ConfigureQuery q -> Qualified SubQuery -- ^ 'SubQuery' to join -> QueryJoin q (Record c r) -- ^ Result joined context and record of 'SubQuery' result. unsafeSubQueryWithAttr attr qsub = do + let r = Record.unsafeFromQualifiedSubQuery qsub addAS <- addQueryTableAliasAS <$> liftQualify askConfig - updateContext (updateProduct (`growProduct` (attr, (addAS, qsub)))) - return $ Record.unsafeFromQualifiedSubQuery qsub + updateContext (placeholderOffsetsOfRecord r) (updateProduct (`growProduct` (attr, (addAS, qsub)))) + return $ emptyPlaceholderOffsetsOfRecord r -- | Basic monadic join operation using 'MonadQuery'. queryWithAttr :: NodeAttr + -> Record PureOperand p -> 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 + -> QueryJoin ConfigureQuery (Record c r) +queryWithAttr attr phs rel = do + q <- liftQualify $ do + sq <- untypeRelation rel phs + 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) +extractProduct :: Functor m => QueryJoin m a -> m ((a, WithPlaceholderOffsets JoinProduct), Duplication) +extractProduct (QueryJoin s) = (second (fmap joinProduct) *** (fromMaybe All . getLast)) + <$> runWriterT (runStateT s $ attachEmptyPlaceholderOffsets primeJoinContext) diff --git a/relational-query/src/Database/Relational/Monad/Trans/JoinState.hs b/relational-query/src/Database/Relational/Monad/Trans/JoinState.hs index 79fb7e92..d6ce26ac 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/JoinState.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/JoinState.hs @@ -19,15 +19,14 @@ module Database.Relational.Monad.Trans.JoinState ( import Prelude hiding (product) import Data.DList (DList, toList) -import Database.Relational.Internal.ContextType (Flat) -import Database.Relational.SqlSyntax (JoinProduct, Node, Predicate) +import Database.Relational.SqlSyntax (JoinProduct, Node, Tuple) import qualified Database.Relational.SqlSyntax as Product -- | JoinContext type for QueryJoin. newtype JoinContext = JoinContext - { product :: Maybe (Node (DList (Predicate Flat))) + { product :: Maybe (Node (DList Tuple)) } -- | Initial 'JoinContext'. @@ -35,7 +34,7 @@ primeJoinContext :: JoinContext primeJoinContext = JoinContext Nothing -- | Update product of 'JoinContext'. -updateProduct :: (Maybe (Node (DList (Predicate Flat))) -> Node (DList (Predicate Flat))) +updateProduct :: (Maybe (Node (DList Tuple)) -> Node (DList Tuple)) -> JoinContext -> JoinContext updateProduct uf ctx = ctx { product = Just . uf . product $ ctx } diff --git a/relational-query/src/Database/Relational/Monad/Trans/Ordering.hs b/relational-query/src/Database/Relational/Monad/Trans/Ordering.hs index 98468787..357f8a09 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Ordering.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Ordering.hs @@ -27,12 +27,12 @@ module Database.Relational.Monad.Trans.Ordering ( import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) -import Control.Applicative (Applicative, pure, (<$>)) +import Control.Applicative (Applicative, (<$>)) import Control.Arrow (second) -import Data.DList (DList, toList) +import Data.DList (DList, toList, fromList) import Database.Relational.SqlSyntax - (Order (..), Nulls (..), OrderingTerm, Record, untypeRecord) + (Order (..), Nulls (..), OrderingTerm, Record, WithPlaceholderOffsets, untypeRecordWithPlaceholderOffsets) import Database.Relational.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery(..), MonadAggregate(..), MonadPartition(..)) @@ -41,7 +41,7 @@ import Database.Relational.Monad.Class -- | Type to accumulate ordering context. -- Type 'c' is ordering term record context type. newtype Orderings c m a = - Orderings (WriterT (DList OrderingTerm) m a) + Orderings (WriterT (WithPlaceholderOffsets (DList OrderingTerm)) m a) deriving (MonadTrans, Monad, Functor, Applicative) -- | Lift to 'Orderings'. @@ -60,8 +60,8 @@ instance MonadQualify q m => MonadQualify q (Orderings c m) where instance MonadQuery m => MonadQuery (Orderings c m) where setDuplication = orderings . setDuplication restrictJoin = orderings . restrictJoin - query' = orderings . query' - queryMaybe' = orderings . queryMaybe' + query' ph = orderings . query' ph + queryMaybe' ph = orderings . queryMaybe' ph -- | 'MonadAggregate' with ordering. instance MonadAggregate m => MonadAggregate (Orderings c m) where @@ -75,14 +75,15 @@ instance MonadPartition c m => MonadPartition c (Orderings c m) where -- | Add ordering terms. updateOrderBys :: Monad m => (Order, Maybe Nulls) -- ^ Order direction - -> Record c t -- ^ Ordering terms to add + -> Record c t -- ^ Ordering terms to add -> Orderings c m () -- ^ Result context with ordering -updateOrderBys opair p = Orderings . mapM_ tell $ terms where - terms = curry pure opair `map` untypeRecord p +updateOrderBys opair p = Orderings . tell $ terms where + terms :: WithPlaceholderOffsets (DList OrderingTerm) + terms = fromList . map ((,) opair) <$> untypeRecordWithPlaceholderOffsets p -- | Add ordering terms with null ordering. orderBy' :: Monad m - => Record c t -- ^ Ordering terms to add + => Record c t -- ^ Ordering terms to add -> Order -- ^ Order direction -> Nulls -- ^ Order of null -> Orderings c m () -- ^ Result context with ordering @@ -90,23 +91,23 @@ 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 + => 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 + => 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 + => 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 +extractOrderingTerms :: (Monad m, Functor m) => Orderings c m a -> m (a, WithPlaceholderOffsets [OrderingTerm]) +extractOrderingTerms (Orderings oc) = second (fmap toList) <$> runWriterT oc diff --git a/relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders.hs b/relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders.hs new file mode 100644 index 00000000..5226292f --- /dev/null +++ b/relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.Relational.Monad.Trans.Config +-- Copyright : 2019 IIJ Innovation Institute Inc. +-- License : BSD3 +-- +-- Maintainer : yuji-yamamoto@iij.ad.jp +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which requires query generate configuration. +module Database.Relational.Monad.Trans.ReadPlaceholders ( + module Database.Relational.Monad.Trans.ReadPlaceholders.Type + ) where + +import Database.Relational.Monad.Trans.ReadPlaceholders.Type +import Database.Relational.Monad.Class + (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) + +-- | 'MonadRestrict' instance. +instance MonadRestrict c m => MonadRestrict c (ReadPlaceholders p m) where + restrict = readPlaceholders . restrict + +-- | Restricted 'MonadQualify' instance. +instance MonadQualify q m => MonadQualify q (ReadPlaceholders p m) where + liftQualify = readPlaceholders . liftQualify + +-- | Restricted 'MonadQuery' instance. +instance MonadQuery q => MonadQuery (ReadPlaceholders p q) where + setDuplication = readPlaceholders . setDuplication + restrictJoin = readPlaceholders . restrictJoin + query' ph = readPlaceholders . query' ph + queryMaybe' ph = readPlaceholders . queryMaybe' ph + +-- | Resticted 'MonadAggregate' instance. +instance MonadAggregate m => MonadAggregate (ReadPlaceholders p m) where + groupBy = readPlaceholders . groupBy + groupBy' = readPlaceholders . groupBy' diff --git a/relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders/Type.hs b/relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders/Type.hs new file mode 100644 index 00000000..2452e018 --- /dev/null +++ b/relational-query/src/Database/Relational/Monad/Trans/ReadPlaceholders/Type.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Database.Relational.Monad.Trans.Config +-- Copyright : 2019 IIJ Innovation Institute Inc. +-- License : BSD3 +-- +-- Maintainer : yuji-yamamoto@iij.ad.jp +-- Stability : experimental +-- Portability : unknown +-- +-- This module defines monad transformer which requires query generate configuration. +module Database.Relational.Monad.Trans.ReadPlaceholders.Type ( + -- * Transformer into query with configuration + ReadPlaceholders, readPlaceholders, + runReadPlaceholders, askPlaceholders, + ) where + +import Control.Applicative (Applicative) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) + +import Database.Relational.Internal.ContextType (PureOperand) +import Database.Relational.SqlSyntax (Record) + + +-- | 'ReaderT' type to require query generate configuration. +newtype ReadPlaceholders p m a = + ReadPlaceholders (ReaderT (Record PureOperand p) m a) + deriving (Monad, Functor, Applicative) + +-- | Run 'ReadPlaceholders' to expand with configuration +runReadPlaceholders :: ReadPlaceholders p m a -> Record PureOperand p -> m a +runReadPlaceholders (ReadPlaceholders r) = runReaderT r + +-- | Lift to 'ReadPlaceholders'. +readPlaceholders :: Monad m => m a -> ReadPlaceholders p m a +readPlaceholders = ReadPlaceholders . lift + +-- | Read configuration. +askPlaceholders :: Monad m => ReadPlaceholders p m (Record PureOperand p) +askPlaceholders = ReadPlaceholders ask diff --git a/relational-query/src/Database/Relational/Monad/Trans/Restricting.hs b/relational-query/src/Database/Relational/Monad/Trans/Restricting.hs index 6b333a27..c76ccfe3 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Restricting.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Restricting.hs @@ -22,11 +22,11 @@ module Database.Relational.Monad.Trans.Restricting ( import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) -import Control.Applicative (Applicative, pure, (<$>)) +import Control.Applicative (Applicative, (<$>)) import Control.Arrow (second) -import Data.DList (DList, toList) +import Data.DList (DList, toList, singleton) -import Database.Relational.SqlSyntax (Predicate) +import Database.Relational.SqlSyntax (Predicate, Tuple, WithPlaceholderOffsets, untypeRecordWithPlaceholderOffsets) import Database.Relational.Monad.Class (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..)) @@ -36,8 +36,11 @@ import Database.Relational.Monad.Class -- 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) + Restrictings (WriterT (DList (WithPlaceholderOffsets Tuple)) m a) + deriving (Monad, Functor, Applicative) + +instance MonadTrans (Restrictings c) where + lift = Restrictings . lift -- | Lift to 'Restrictings' restrictings :: Monad m => m a -> Restrictings c m a @@ -45,7 +48,7 @@ restrictings = lift -- | Add whole query restriction. updateRestriction :: Monad m => Predicate c -> Restrictings c m () -updateRestriction = Restrictings . tell . pure +updateRestriction = Restrictings . tell . singleton . untypeRecordWithPlaceholderOffsets -- | 'MonadRestrict' instance. instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where @@ -59,8 +62,8 @@ instance MonadQualify q m => MonadQualify q (Restrictings c m) where instance MonadQuery q => MonadQuery (Restrictings c q) where setDuplication = restrictings . setDuplication restrictJoin = restrictings . restrictJoin - query' = restrictings . query' - queryMaybe' = restrictings . queryMaybe' + query' ph = restrictings . query' ph + queryMaybe' ph = restrictings . queryMaybe' ph -- | Resticted 'MonadAggregate' instance. instance MonadAggregate m => MonadAggregate (Restrictings c m) where @@ -68,5 +71,5 @@ instance MonadAggregate m => MonadAggregate (Restrictings c m) where groupBy' = restrictings . groupBy' -- | Run 'Restrictings' to get 'QueryRestriction' -extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, [Predicate c]) +extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, [WithPlaceholderOffsets Tuple]) extractRestrict (Restrictings rc) = second toList <$> runWriterT rc diff --git a/relational-query/src/Database/Relational/Monad/Type.hs b/relational-query/src/Database/Relational/Monad/Type.hs index b9386ab0..2b970bc9 100644 --- a/relational-query/src/Database/Relational/Monad/Type.hs +++ b/relational-query/src/Database/Relational/Monad/Type.hs @@ -16,9 +16,8 @@ module Database.Relational.Monad.Type import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax - (Duplication, Record, JoinProduct, Predicate, ) + (Duplication, Record, JoinProduct, Tuple, WithPlaceholderOffsets, ) -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) @@ -30,8 +29,8 @@ type QueryCore = Restrictings Flat (QueryJoin ConfigureQuery) -- | Extract 'QueryCore' computation. extractCore :: QueryCore a - -> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication) + -> ConfigureQuery (((a, [WithPlaceholderOffsets Tuple]), WithPlaceholderOffsets 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) +type OrderedQuery c m r = Orderings c m (Record c r) diff --git a/relational-query/src/Database/Relational/Monad/Unique.hs b/relational-query/src/Database/Relational/Monad/Unique.hs index 1433130f..b9db4b32 100644 --- a/relational-query/src/Database/Relational/Monad/Unique.hs +++ b/relational-query/src/Database/Relational/Monad/Unique.hs @@ -21,19 +21,16 @@ module Database.Relational.Monad.Unique import Control.Applicative (Applicative) -import Database.Relational.Internal.ContextType (Flat) import Database.Relational.SqlSyntax (Duplication, Record, JoinProduct, NodeAttr, - SubQuery, Predicate, Qualified, ) + SubQuery, Tuple, 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) +import Database.Relational.SqlSyntax (flatSubQuery, WithPlaceholderOffsets, untypeRecordWithPlaceholderOffsets, ) -- | Unique query monad type. @@ -47,13 +44,13 @@ unsafeUniqueSubQuery :: NodeAttr -- ^ Attribute maybe or just unsafeUniqueSubQuery a = QueryUnique . restrictings . unsafeSubQueryWithAttr a extract :: QueryUnique a - -> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication) + -> ConfigureQuery (((a, [WithPlaceholderOffsets Tuple]), WithPlaceholderOffsets 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 :: QueryUnique (Record c r) -- ^ 'QueryUnique' to run + -> ConfigureQuery SubQuery -- ^ Result 'SubQuery' with 'Qualify' computation toSubQuery q = do - ((((_ph, pj), rs), pd), da) <- extract q + (((pj, rs), pd), da) <- extract q c <- askConfig - return $ flatSubQuery c (Record.untype pj) da pd rs [] + return $ flatSubQuery c (untypeRecordWithPlaceholderOffsets pj) da pd rs mempty diff --git a/relational-query/src/Database/Relational/Projectable.hs b/relational-query/src/Database/Relational/Projectable.hs index 438f3d73..c66c5d8e 100644 --- a/relational-query/src/Database/Relational/Projectable.hs +++ b/relational-query/src/Database/Relational/Projectable.hs @@ -15,8 +15,9 @@ -- This module defines operators on various projected records. module Database.Relational.Projectable ( -- * Projectable from SQL strings - SqlContext (unsafeProjectSqlTerms), unsafeProjectSql', - unsafeProjectSql, + SqlContext, unsafeProjectSqlTerms, + unsafeProjectSql', unsafeProjectSql, + unsafeProjectSqlWithPlaceholders', unsafeProjectSqlWithPlaceholders, -- * Records of values value, @@ -24,10 +25,6 @@ module Database.Relational.Projectable ( values, nothing, - -- * Placeholders - PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders, - pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH, - -- * Projectable into SQL strings unsafeShowSql', unsafeShowSql, @@ -80,7 +77,7 @@ import Prelude hiding (pi) import Data.String (IsString) import Data.Functor.ProductIsomorphic - ((|$|), ProductIsoApplicative, pureP, (|*|), ) + ((|$|), ProductIsoApplicative, (|*|), ) import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL @@ -90,7 +87,7 @@ import Database.Record HasColumnConstraint, NotNull) import Database.Record.Persistable (runPersistableRecordWidth) -import Database.Relational.Internal.ContextType (Flat, Exists, OverWindow) +import Database.Relational.Internal.ContextType (Flat, PureOperand, Exists, OverWindow) import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) import Database.Relational.SqlSyntax (Record, Predicate) import qualified Database.Relational.SqlSyntax as Syntax @@ -103,47 +100,55 @@ import Database.Relational.ProjectableClass import Database.Relational.Record (RecordList) import qualified Database.Relational.Record as Record import Database.Relational.Projectable.Unsafe - (SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..)) + (SqlContext (..), OperatorContext, AggregatedContext, unsafeProjectSqlTerms,) import Database.Relational.Projectable.Instances () -- | Unsafely Project single SQL term. unsafeProjectSql' :: SqlContext c => StringSQL -> Record c t -unsafeProjectSql' = unsafeProjectSqlTerms . (:[]) +unsafeProjectSql' = unsafeProjectSqlWithPlaceholders' . Syntax.withPlaceholderOffsets mempty -- | Unsafely Project single SQL string. String interface of 'unsafeProjectSql'''. unsafeProjectSql :: SqlContext c => String -> Record c t -unsafeProjectSql = unsafeProjectSql' . stringSQL +unsafeProjectSql = unsafeProjectSqlWithPlaceholders . Syntax.withPlaceholderOffsets mempty + +unsafeProjectSqlWithPlaceholders' :: SqlContext c => Syntax.SQLWithPlaceholderOffsets' -> Record c t +unsafeProjectSqlWithPlaceholders' = unsafeProjectSqlTermsWithPlaceholders . fmap (:[]) + +unsafeProjectSqlWithPlaceholders :: SqlContext c => Syntax.SQLWithPlaceholderOffsets -> Record c t +unsafeProjectSqlWithPlaceholders = unsafeProjectSqlWithPlaceholders' . fmap 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 :: PersistableWidth a => Record PureOperand (Maybe a) nothing = proxyWidth persistableWidth where - proxyWidth :: SqlContext c => PersistableRecordWidth a -> Record c (Maybe a) + proxyWidth :: PersistableRecordWidth a -> Record PureOperand (Maybe a) proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL -- | Generate record with polymorphic type of SQL constant values from Haskell value. -value :: (LiteralSQL t, OperatorContext c) => t -> Record c t +value :: LiteralSQL t => t -> Record PureOperand t value = unsafeProjectSqlTerms . showLiteral -- | Record with polymorphic type of SQL true value. -valueTrue :: OperatorContext c => Record c (Maybe Bool) +valueTrue :: Record PureOperand (Maybe Bool) valueTrue = just $ value True -- | Record with polymorphic type of SQL false value. -valueFalse :: OperatorContext c => Record c (Maybe Bool) +valueFalse :: Record PureOperand (Maybe Bool) valueFalse = just $ value False -- | RecordList with polymorphic type of SQL set value from Haskell list. values :: (LiteralSQL t, OperatorContext c) => [t] -> RecordList (Record c) t -values = Record.list . map value - +values = Record.list . map (unsafeProjectSqlTerms . showLiteral) -- | Unsafely generate SQL expression term from record object. unsafeShowSql' :: Record c a -> StringSQL unsafeShowSql' = Record.unsafeStringSql +-- | Unsafely generate SQL expression term from record object. +unsafeShowSqlWithPlaceholders' :: Record c a -> Syntax.SQLWithPlaceholderOffsets' +unsafeShowSqlWithPlaceholders' = Record.unsafeStringSqlWithPlaceholders + -- | Unsafely generate SQL expression string from record object. -- String interface of 'unsafeShowSql''. unsafeShowSql :: Record c a -- ^ Source record object @@ -157,7 +162,8 @@ 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' +unsafeUniOp u = + unsafeProjectSqlWithPlaceholders' . fmap u . unsafeShowSqlWithPlaceholders' unsafeFlatUniOp :: SqlContext c => Keyword -> Record c a -> Record c b @@ -167,8 +173,8 @@ unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw) 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) +unsafeBinOp op a b = + unsafeProjectSqlWithPlaceholders' (SQL.paren <$> (op <$> unsafeShowSqlWithPlaceholders' a <*> unsafeShowSqlWithPlaceholders' b)) -- | Unsafely make binary operator to compare records from string binary operator. compareBinOp :: SqlContext c @@ -231,8 +237,8 @@ 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' +exists rl = + unsafeProjectSqlWithPlaceholders' (SQL.paren . SQL.defineUniOp SQL.EXISTS <$> Record.unsafeStringSqlList unsafeShowSqlWithPlaceholders' rl) -- | Concatinate operator corresponding SQL /||/ . (.||.) :: OperatorContext c @@ -261,12 +267,12 @@ x `likeMaybe'` y = x `unsafeLike` y -- | String-compare operator corresponding SQL /LIKE/ . like :: (OperatorContext c, IsString a, LiteralSQL a) => Record c a -> a -> Record c (Maybe Bool) -x `like` a = x `like'` value a +x `like` a = x `like'` Record.toSomeOperatorContext (value a) -- | String-compare operator corresponding SQL /LIKE/ . Maybe type version. likeMaybe :: (OperatorContext c, IsString a, LiteralSQL a) => Record c (Maybe a) -> a -> Record c (Maybe Bool) -x `likeMaybe` a = x `unsafeLike` value a +x `likeMaybe` a = x `unsafeLike` Record.toSomeOperatorContext (value a) -- | Unsafely make number binary operator for records from SQL operator string. monoBinOp' :: SqlContext c @@ -300,7 +306,7 @@ negate' = unsafeFlatUniOp $ SQL.word "-" unsafeCastProjectable :: SqlContext c => Record c a -> Record c b -unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql' +unsafeCastProjectable = unsafeProjectSqlWithPlaceholders' . unsafeShowSqlWithPlaceholders' -- | Number fromIntegral uni-operator. fromIntegral' :: (SqlContext c, Integral a, Num b) @@ -366,7 +372,7 @@ casesOrElse = 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 +caseSearchMaybe cs = caseSearch cs (Record.toSomeOperatorContext nothing) -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ @@ -389,13 +395,13 @@ caseMaybe :: (OperatorContext c {- (Record c) is always ProjectableMaybe -}, Per => 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 +caseMaybe v cs = case' v cs (Record.toSomeOperatorContext 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) +in' a lp = unsafeProjectSqlWithPlaceholders' + $ fmap SQL.paren (SQL.in' <$> (unsafeShowSqlWithPlaceholders' a) <*> (Record.unsafeStringSqlList unsafeShowSqlWithPlaceholders' lp)) -- | Operator corresponding SQL /IS NULL/ , and extended against record types. isNothing :: (OperatorContext c, HasColumnConstraint NotNull r) @@ -437,50 +443,6 @@ percentRank = unsafeUniTermFunction SQL.PERCENT_RANK cumeDist :: Record OverWindow Double cumeDist = unsafeUniTermFunction SQL.CUME_DIST --- | Unsafely add placeholder parameter to queries. -unsafeAddPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a) -unsafeAddPlaceHolders = fmap ((,) PlaceHolders) - --- | Unsafely get placeholder parameter -unsafePlaceHolders :: PlaceHolders p -unsafePlaceHolders = PlaceHolders - --- | No placeholder semantics -unitPlaceHolder :: PlaceHolders () -unitPlaceHolder = pureP () - --- | No placeholder semantics. Same as `unitPlaceHolder` -unitPH :: PlaceHolders () -unitPH = pureP () - --- | Unsafely cast placeholder parameter type. -unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b -unsafeCastPlaceHolders PlaceHolders = PlaceHolders - --- | Provide scoped placeholder from width and return its parameter object. -pwPlaceholder :: SqlContext c - => PersistableRecordWidth a - -> (Record c a -> b) - -> (PlaceHolders a, b) -pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw) - where - projectPlaceHolder :: SqlContext c - => PersistableRecordWidth a - -> Record c a - projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth - --- | Provide scoped placeholder and return its parameter object. -placeholder' :: (PersistableWidth t, SqlContext c) => (Record c t -> a) -> (PlaceHolders t, a) -placeholder' = pwPlaceholder persistableWidth - --- | Provide scoped placeholder and return its parameter object. Monadic version. -placeholder :: (PersistableWidth t, SqlContext c, Monad m) => (Record c t -> m a) -> m (PlaceHolders t, a) -placeholder f = do - let (ph, ma) = placeholder' f - a <- ma - return (ph, a) - - -- | Zipping projections. projectZip :: ProductIsoApplicative p => p a -> p b -> p (a, b) projectZip pa pb = (,) |$| pa |*| pb @@ -496,11 +458,6 @@ class ProjectableMaybe p where -- | 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 diff --git a/relational-query/src/Database/Relational/Projectable/Instances.hs b/relational-query/src/Database/Relational/Projectable/Instances.hs index 92dbd34c..2ec69f37 100644 --- a/relational-query/src/Database/Relational/Projectable/Instances.hs +++ b/relational-query/src/Database/Relational/Projectable/Instances.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Database.Relational.Projectable.Instances @@ -13,53 +14,46 @@ -- This module provides instances between projected terms and SQL terms. module Database.Relational.Projectable.Instances () where -import Data.Functor.ProductIsomorphic - (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), - ProductIsoEmpty, pureE, peRight, peLeft, ) - import Database.Relational.Internal.ContextType - (Flat, Aggregated, OverWindow) + (Flat, Aggregated, OverWindow, PureOperand) import qualified Database.Relational.Record as Record import Database.Relational.Projectable.Unsafe - (SqlContext (..), OperatorContext, AggregatedContext, PlaceHolders (..)) + (SqlContext (..), OperatorContext, AggregatedContext, ResultContext,) -- context -- | Unsafely make 'Record' from SQL terms. instance SqlContext Flat where - unsafeProjectSqlTerms = Record.unsafeFromSqlTerms + unsafeProjectSqlTermsWithPlaceholders = Record.unsafeFromSqlTerms -- | Unsafely make 'Record' from SQL terms. instance SqlContext Aggregated where - unsafeProjectSqlTerms = Record.unsafeFromSqlTerms + unsafeProjectSqlTermsWithPlaceholders = Record.unsafeFromSqlTerms -- | Unsafely make 'Record' from SQL terms. instance SqlContext OverWindow where - unsafeProjectSqlTerms = Record.unsafeFromSqlTerms + unsafeProjectSqlTermsWithPlaceholders = Record.unsafeFromSqlTerms + +-- | Unsafely make 'Record' from SQL terms. +instance SqlContext PureOperand where + unsafeProjectSqlTermsWithPlaceholders = Record.unsafeFromSqlTerms -- | full SQL expression is availabe in Flat context instance OperatorContext Flat -- | full SQL expression is availabe in Aggregated context instance OperatorContext Aggregated +-- | full SQL expression is availabe in PureOperand context +instance OperatorContext PureOperand -- | 'Aggregated' context is aggregated context instance AggregatedContext Aggregated -- | 'OverWindow' context is aggregated context instance AggregatedContext OverWindow --- placeholders - --- | Zipping except for identity element laws against placeholder parameter type. -instance ProductIsoEmpty PlaceHolders () where - pureE = PlaceHolders - peRight _ = PlaceHolders - peLeft _ = PlaceHolders - --- | Compose seed of record type 'PlaceHolders'. -instance ProductIsoFunctor PlaceHolders where - _ |$| PlaceHolders = PlaceHolders +type instance ResultContext Flat Flat = Flat +type instance ResultContext Flat PureOperand = Flat +type instance ResultContext PureOperand Flat = Flat --- | Compose record type 'PlaceHolders' using applicative style. -instance ProductIsoApplicative PlaceHolders where - pureP _ = PlaceHolders - _pf |*| _pa = PlaceHolders +type instance ResultContext Aggregated Aggregated = Aggregated +type instance ResultContext Aggregated PureOperand = Aggregated +type instance ResultContext PureOperand Aggregated = Aggregated diff --git a/relational-query/src/Database/Relational/Projectable/Unsafe.hs b/relational-query/src/Database/Relational/Projectable/Unsafe.hs index e8a9a243..e4ee7acc 100644 --- a/relational-query/src/Database/Relational/Projectable/Unsafe.hs +++ b/relational-query/src/Database/Relational/Projectable/Unsafe.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Database.Relational.Projectable.Unsafe -- Copyright : 2017 Kei Hibino @@ -10,17 +12,18 @@ -- This module provides unsafe interfaces between projected terms and SQL terms. module Database.Relational.Projectable.Unsafe ( SqlContext (..), OperatorContext, AggregatedContext, - PlaceHolders (..) + ResultContext, + unsafeProjectSqlTerms, ) where import Database.Relational.Internal.String (StringSQL) -import Database.Relational.SqlSyntax (Record) +import Database.Relational.SqlSyntax (Record, WithPlaceholderOffsets, attachEmptyPlaceholderOffsets) -- | Interface to project SQL terms unsafely. class SqlContext c where -- | Unsafely project from SQL expression terms. - unsafeProjectSqlTerms :: [StringSQL] - -> Record c t + unsafeProjectSqlTermsWithPlaceholders + :: WithPlaceholderOffsets [StringSQL] -> Record c t -- | Constraint to restrict context of full SQL expressions. -- For example, the expression at the left of OVER clause @@ -30,6 +33,7 @@ class SqlContext c => OperatorContext c -- | Constraint to restrict context of aggregated SQL context. class AggregatedContext ac +type family ResultContext c1 c2 --- | Placeholder parameter type which has real parameter type arguemnt 'p'. -data PlaceHolders p = PlaceHolders +unsafeProjectSqlTerms :: SqlContext c => [StringSQL] -> Record c t +unsafeProjectSqlTerms = unsafeProjectSqlTermsWithPlaceholders . attachEmptyPlaceholderOffsets diff --git a/relational-query/src/Database/Relational/Record.hs b/relational-query/src/Database/Relational/Record.hs index 0c8f482e..1cd4d8e7 100644 --- a/relational-query/src/Database/Relational/Record.hs +++ b/relational-query/src/Database/Relational/Record.hs @@ -18,7 +18,9 @@ module Database.Relational.Record ( width, columns, + columnsWithPlaceholders, untype, + pempty, unsafeFromSqlTerms, unsafeFromQualifiedSubQuery, @@ -26,6 +28,7 @@ module Database.Relational.Record ( unsafeFromTable, unsafeStringSql, + unsafeStringSqlWithPlaceholders, -- * Projections pi, piMaybe, piMaybe', @@ -34,6 +37,7 @@ module Database.Relational.Record ( flattenMaybe, just, unsafeToAggregated, unsafeToFlat, unsafeChangeContext, + toAggregated, toFlat, toSomeOperatorContext, unsafeStringSqlNotNullMaybe, -- * List of Record @@ -42,6 +46,7 @@ module Database.Relational.Record ( ) where import Prelude hiding (pi) +import qualified Data.DList as DList import Data.Functor.ProductIsomorphic (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), ProductIsoEmpty, pureE, peRight, peLeft, ) @@ -52,27 +57,37 @@ import Database.Record (HasColumnConstraint, NotNull, NotNullColumnConstraint, P import Database.Record.Persistable (PersistableRecordWidth) import qualified Database.Record.KeyConstraint as KeyConstraint -import Database.Relational.Internal.ContextType (Aggregated, Flat) +import Database.Relational.Internal.ContextType (Aggregated, Flat, PureOperand) import Database.Relational.Internal.String (StringSQL, listStringSQL, rowStringSQL) import Database.Relational.SqlSyntax (SubQuery, Qualified, Tuple, Record, - recordRawColumns, tupleFromJoinedSubQuery,) + typedTupleRawColumns, 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 +import Database.Relational.Projectable.Unsafe (OperatorContext) -- | Unsafely get SQL term from 'Record'. unsafeStringSql :: Record c r -> StringSQL -unsafeStringSql = rowStringSQL . recordRawColumns +unsafeStringSql = + rowStringSQL . typedTupleRawColumns . Syntax.detachPlaceholderOffsets . Syntax.toTypedTuple + +unsafeStringSqlWithPlaceholders :: Record c r -> Syntax.SQLWithPlaceholderOffsets' +unsafeStringSqlWithPlaceholders = + fmap (rowStringSQL . typedTupleRawColumns) . Syntax.toTypedTuple -- | Get column SQL string list of record. columns :: Record c r -- ^ Source 'Record' -> [StringSQL] -- ^ Result SQL string list -columns = recordRawColumns +columns = + Syntax.typedTupleRawColumns . Syntax.detachPlaceholderOffsets . Syntax.toTypedTuple + +columnsWithPlaceholders :: Record c r -> Syntax.WithPlaceholderOffsets [StringSQL] +columnsWithPlaceholders = fmap Syntax.typedTupleRawColumns . Syntax.toTypedTuple -- | Width of 'Record'. width :: Record c r -> Int @@ -82,31 +97,35 @@ width = Syntax.recordWidth 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 +unsafeFromQualifiedSubQuery = + Syntax.unsafeRecordFromTupleWithPlaceholderOffsets . tupleFromJoinedSubQuery -- | Unsafely generate 'Record' from scalar sub-query. unsafeFromScalarSubQuery :: SubQuery -> Record c t -unsafeFromScalarSubQuery = Syntax.typeFromScalarSubQuery +unsafeFromScalarSubQuery sq = + Syntax.record (Syntax.collectPlaceholderOffsets sq) . (:[]) $ Syntax.Scalar sq -- | Unsafely generate unqualified 'Record' from 'Table'. unsafeFromTable :: Table r -> Record c r -unsafeFromTable = Syntax.typeFromRawColumns . Table.columns +unsafeFromTable = Syntax.typeFromRawColumns mempty . Table.columns -- | Unsafely generate 'Record' from SQL expression strings. -unsafeFromSqlTerms :: [StringSQL] -> Record c t -unsafeFromSqlTerms = Syntax.typeFromRawColumns - +unsafeFromSqlTerms :: Syntax.WithPlaceholderOffsets [StringSQL] -> Record c t +unsafeFromSqlTerms = uncurry (flip Syntax.typeFromRawColumns) . Syntax.tupleFromPlaceholderOffsets -- | 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 + Syntax.typeFromRawColumns phs + . (UnsafePi.pi w pi') + $ columns p + where + phs = if Syntax.isPlaceholdersRecord p + then DList.fromList $ UnsafePi.unsafeExpandIndexes' w pi' + else mempty -- | Trace projection path to get narrower 'Record'. wpi :: PersistableRecordWidth a @@ -138,7 +157,7 @@ piMaybe' :: PersistableWidth a piMaybe' = unsafeProject persistableWidth unsafeCast :: Record c r -> Record c r' -unsafeCast = Syntax.record . Syntax.untypeRecord +unsafeCast = Syntax.mapTypedTuple (Syntax.forciblyTypeTuple . Syntax.untypeTuple) -- | Composite nested 'Maybe' on record phantom type. flattenMaybe :: Record c (Maybe (Maybe a)) -> Record c (Maybe a) @@ -150,7 +169,7 @@ just = unsafeCast -- | Unsafely cast context type tag. unsafeChangeContext :: Record c r -> Record c' r -unsafeChangeContext = Syntax.record . Syntax.untypeRecord +unsafeChangeContext = Syntax.mapTypedTuple (Syntax.forciblyTypeTuple . Syntax.untypeTuple) -- | Unsafely lift to aggregated context. unsafeToAggregated :: Record Flat r -> Record Aggregated r @@ -160,6 +179,18 @@ unsafeToAggregated = unsafeChangeContext unsafeToFlat :: Record Aggregated r -> Record Flat r unsafeToFlat = unsafeChangeContext +-- | Convert pure operand context into aggregated context. +toAggregated :: Record PureOperand r -> Record Aggregated r +toAggregated = unsafeChangeContext + +-- | Convert pure operand context into flat context. +toFlat :: Record PureOperand r -> Record Flat r +toFlat = unsafeChangeContext + +-- | Convert pure operand context into some operator context. +toSomeOperatorContext :: OperatorContext c => Record PureOperand r -> Record c r +toSomeOperatorContext = unsafeChangeContext + notNullMaybeConstraint :: HasColumnConstraint NotNull r => Record c (Maybe r) -> NotNullColumnConstraint r notNullMaybeConstraint = const KeyConstraint.columnConstraint @@ -168,7 +199,7 @@ unsafeStringSqlNotNullMaybe :: HasColumnConstraint NotNull r => Record c (Maybe unsafeStringSqlNotNullMaybe p = (!! KeyConstraint.index (notNullMaybeConstraint p)) . columns $ p pempty :: Record c () -pempty = Syntax.record [] +pempty = Syntax.record mempty [] -- | Map 'Record' which result type is record. instance ProductIsoFunctor (Record c) where @@ -177,7 +208,9 @@ instance ProductIsoFunctor (Record c) where -- | Compose 'Record' using applicative style. instance ProductIsoApplicative (Record c) where pureP _ = unsafeCast pempty - pf |*| pa = Syntax.record $ Syntax.untypeRecord pf ++ Syntax.untypeRecord pa + pff |*| pfa = Syntax.Record (Syntax.forciblyTypeTuple <$> csphs) + where + csphs = (++) <$> Syntax.untypeRecordWithPlaceholderOffsets pff <*> Syntax.untypeRecordWithPlaceholderOffsets pfa instance ProductIsoEmpty (Record c) () where pureE = pureP () @@ -197,7 +230,7 @@ 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 :: (p t -> Syntax.SQLWithPlaceholderOffsets') -> RecordList p t -> Syntax.SQLWithPlaceholderOffsets' unsafeStringSqlList sf = d where - d (List ps) = listStringSQL $ map sf ps - d (Sub sub) = SQL.paren $ Syntax.showSQL sub + d (List ps) = listStringSQL <$> traverse sf ps + d (Sub sub) = Syntax.withPlaceholderOffsets (Syntax.collectPlaceholderOffsets sub) . SQL.paren $ Syntax.showSQL sub diff --git a/relational-query/src/Database/Relational/Relation.hs b/relational-query/src/Database/Relational/Relation.hs index ae058019..be3225e4 100644 --- a/relational-query/src/Database/Relational/Relation.hs +++ b/relational-query/src/Database/Relational/Relation.hs @@ -29,7 +29,8 @@ module Database.Relational.Relation ( import Control.Applicative ((<$>)) -import Database.Relational.Internal.ContextType (Flat, Aggregated) +import Database.Record (PersistableWidth) +import Database.Relational.Internal.ContextType (Flat, Aggregated, PureOperand) import Database.Relational.SqlSyntax (NodeAttr(Just', Maybe), Record, ) import Database.Relational.Monad.BaseType @@ -37,7 +38,8 @@ import Database.Relational.Monad.BaseType Relation, unsafeTypeRelation, untypeRelation, relationWidth) import Database.Relational.Monad.Class (MonadQualify (liftQualify), MonadQuery (query', queryMaybe'), ) -import Database.Relational.Monad.Simple (QuerySimple, SimpleQuery) +import Database.Relational.Monad.Simple (QuerySimple) +import Database.Relational.Monad.Trans.ReadPlaceholders (readPlaceholders, askPlaceholders) import qualified Database.Relational.Monad.Simple as Simple import Database.Relational.Monad.Aggregate (QueryAggregate, AggregatedQuery) import qualified Database.Relational.Monad.Aggregate as Aggregate @@ -47,10 +49,8 @@ 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 Database.Relational.Record (RecordList, pempty) import qualified Database.Relational.Record as Record -import Database.Relational.Projectable - (PlaceHolders, unitPlaceHolder, unsafeAddPlaceHolders, unsafePlaceHolders, ) -- | Simple 'Relation' from 'Table'. @@ -65,14 +65,11 @@ derivedRelation = table derivedTable 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' +query = query' pempty -- | Join sub-query. Query result is 'Maybe'. -- The combinations of 'query' and 'queryMaybe' express @@ -89,45 +86,41 @@ query = fmap snd . query' queryMaybe :: (MonadQualify ConfigureQuery m, MonadQuery m) => Relation () r -> m (Record Flat (Maybe r)) -queryMaybe = fmap snd . queryMaybe' +queryMaybe = queryMaybe' pempty -queryList0 :: MonadQualify ConfigureQuery m => Relation p r -> m (RecordList (Record c) r) -queryList0 = liftQualify - . fmap Record.unsafeListFromSubQuery - . untypeRelation +queryList0 :: MonadQualify ConfigureQuery m => Record PureOperand p -> Relation p r -> m (RecordList (Record c) r) +queryList0 phs = liftQualify + . fmap Record.unsafeListFromSubQuery + . (`untypeRelation` phs) -- | 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) + => Record PureOperand p + -> Relation p r + -> m (RecordList (Record c) r) +queryList' = queryList0 -- | 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 <$>) +queryList = queryList0 pempty -- | Finalize 'QuerySimple' monad and generate 'Relation' with place-holder parameter 'p'. -relation' :: SimpleQuery p r -> Relation p r -relation' = unsafeTypeRelation . Simple.toSubQuery +relation' :: PersistableWidth p => (Record PureOperand p -> QuerySimple (Record Flat r)) -> Relation p r +relation' f = unsafeTypeRelation $ readPlaceholders . Simple.toSubQuery . f =<< askPlaceholders -- | Finalize 'QuerySimple' monad and generate 'Relation'. relation :: QuerySimple (Record Flat r) -> Relation () r -relation = relation' . addUnitPH +relation = relation' . const -- | Finalize 'QueryAggregate' monad and geneate 'Relation' with place-holder parameter 'p'. -aggregateRelation' :: AggregatedQuery p r -> Relation p r -aggregateRelation' = unsafeTypeRelation . Aggregate.toSubQuery +aggregateRelation' :: PersistableWidth p => (Record PureOperand p -> AggregatedQuery r) -> Relation p r +aggregateRelation' f = unsafeTypeRelation $ readPlaceholders . Aggregate.toSubQuery . f =<< askPlaceholders -- | Finalize 'QueryAggregate' monad and geneate 'Relation'. aggregateRelation :: QueryAggregate (Record Aggregated r) -> Relation () r -aggregateRelation = aggregateRelation' . addUnitPH +aggregateRelation = aggregateRelation' . const -- | Unique relation type to compose scalar queries. @@ -143,50 +136,53 @@ unUnique (Unique r) = r -- | Basic monadic join operation using 'MonadQuery'. uniqueQueryWithAttr :: NodeAttr + -> Record PureOperand p -> 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 + -> QueryUnique (Record c r) +uniqueQueryWithAttr attr phs rel = do + q <- liftQualify $ do + sq <- untypeRelation (unUnique rel) phs + 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' :: Record PureOperand p + -> UniqueRelation p c r + -> QueryUnique (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) +uniqueQueryMaybe' :: Record PureOperand p + -> UniqueRelation p c r + -> QueryUnique (Record c (Maybe r)) +uniqueQueryMaybe' phs pr = do + pj <- uniqueQueryWithAttr Maybe phs pr + return (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 +uniqueRelation' :: PersistableWidth p => (Record PureOperand p -> QueryUnique (Record c r)) -> UniqueRelation p c r +uniqueRelation' f = unsafeUnique . unsafeTypeRelation $ readPlaceholders . Unique.toSubQuery . f =<< askPlaceholders -- | Aggregated 'UniqueRelation'. -aggregatedUnique :: Relation ph r +aggregatedUnique :: PersistableWidth ph + => 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) +aggregatedUnique rel k ag = unsafeUnique . aggregateRelation' $ \phs -> do + a <- query' phs rel + return (ag $ Record.wpi (relationWidth rel phs) 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) + => Record PureOperand p + -> UniqueRelation p c r + -> m (Record c (Maybe r)) +queryScalar' phs ur = + liftQualify $ Record.unsafeFromScalarSubQuery <$> untypeRelation (unUnique ur) phs -- | Scalar sub-query. queryScalar :: (MonadQualify ConfigureQuery m, ScalarDegree r) => UniqueRelation () c r -> m (Record c (Maybe r)) -queryScalar = fmap snd . queryScalar' +queryScalar = queryScalar' pempty diff --git a/relational-query/src/Database/Relational/Sequence.hs b/relational-query/src/Database/Relational/Sequence.hs index 69ceac06..9f7877a4 100644 --- a/relational-query/src/Database/Relational/Sequence.hs +++ b/relational-query/src/Database/Relational/Sequence.hs @@ -41,10 +41,12 @@ import Database.Relational.Table (TableDerivable, derivedTable, Table) import Database.Relational.Pi (Pi) import Database.Relational.Constraint (HasConstraintKey (..), Key, Primary, projectionKey) -import Database.Relational.Projectable ((.<=.), value, unitPH, (!)) +import Database.Relational.Projectable ((.<=.), value, (!)) import Database.Relational.ProjectableClass (LiteralSQL) +import Database.Relational.Record (toFlat) import Database.Relational.Relation (tableOf) import qualified Database.Relational.Relation as Relation +import Database.Relational.Monad.Trans.ReadPlaceholders (readPlaceholders) import Database.Relational.Type (Update, typedUpdate') @@ -139,11 +141,11 @@ updateNumber' :: (PersistableWidth s, Integral i, LiteralSQL i) -> i -- ^ sequence number to set. expect not SQL injectable. -> Sequence s i -- ^ sequence table -> Update () -updateNumber' config i seqt = typedUpdate' config (seqTable seqt) $ \ proj -> do +updateNumber' config i seqt = typedUpdate' config (seqTable seqt) $ \proj -> readPlaceholders $ do let iv = value i seqKey seqt <-# iv - wheres $ proj ! seqKey seqt .<=. iv -- fool proof - return unitPH + wheres $ proj ! seqKey seqt .<=. (toFlat iv) -- fool proof + return () -- | Update statement for sequence table updateNumber :: (PersistableWidth s, Integral i, LiteralSQL i) diff --git a/relational-query/src/Database/Relational/Set.hs b/relational-query/src/Database/Relational/Set.hs index d4e597a0..263a861d 100644 --- a/relational-query/src/Database/Relational/Set.hs +++ b/relational-query/src/Database/Relational/Set.hs @@ -25,7 +25,8 @@ module Database.Relational.Set ( import Data.Functor.ProductIsomorphic ((|$|), (|*|)) -import Database.Relational.Internal.ContextType (Flat) +import Database.Record.Persistable (PersistableWidth) +import Database.Relational.Internal.ContextType (Flat, PureOperand) import Database.Relational.SqlSyntax (Duplication (Distinct, All), SubQuery, Predicate, Record, ) import qualified Database.Relational.SqlSyntax as Syntax @@ -34,8 +35,11 @@ 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.Monad.Trans.ReadPlaceholders (askPlaceholders, readPlaceholders) +import Database.Relational.Record (pempty) import Database.Relational.Relation (relation', relation, query, queryMaybe, ) +import Database.Relational.Projectable ((!)) +import Database.Relational.TupleInstances (fst', snd') -- | Restriction predicate function type for direct style join operator, @@ -46,44 +50,50 @@ import Database.Relational.Relation (relation', relation, query, queryMaybe, ) -- relX `inner` relY `on'` [ \x y -> ... ] -- this lambda form has JoinRestriction type -- ... -- @ -type JoinRestriction a b = Record Flat a -> Record Flat b -> Predicate Flat +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)) +join' :: (PersistableWidth pa, PersistableWidth pb) + => (Record PureOperand pa -> qa -> QuerySimple (Record Flat a)) + -> (Record PureOperand pb -> qb -> QuerySimple (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 +join' qL qR r0 r1 rs = relation' $ \ph -> do + pj0 <- qL (ph ! fst') r0 + pj1 <- qR (ph ! snd') r1 sequence_ [ on $ f pj0 pj1 | f <- rs ] - return ((,) |$| ph0 |*| ph1, (,) |$| pj0 |*| pj1) + return ((,) |$| pj0 |*| pj1) -- | Direct inner join with place-holder parameters. -inner' :: Relation pa a -- ^ Left query to join +inner' :: (PersistableWidth pa, PersistableWidth pb) + => 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 +left' :: (PersistableWidth pa, PersistableWidth pb) + => 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 +right' :: (PersistableWidth pa, PersistableWidth pb) + => 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 +full' :: (PersistableWidth pa, PersistableWidth pb) + => 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 @@ -138,20 +148,25 @@ 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 +liftAppend' :: (PersistableWidth p, PersistableWidth q) + => (SubQuery -> SubQuery -> SubQuery) + -> Relation p a + -> Relation q a + -> Relation (p, q) a +liftAppend' op a0 a1 = unsafeTypeRelation $ do + pq <- askPlaceholders + s0 <- readPlaceholders $ untypeRelation a0 (pq ! fst') + s1 <- readPlaceholders $ untypeRelation a1 (pq ! snd') return $ s0 `op` s1 liftAppend :: (SubQuery -> SubQuery -> SubQuery) -> Relation () a -> Relation () a -> Relation () a -liftAppend = unsafeLiftAppend +liftAppend op a0 a1 = unsafeTypeRelation $ do + s0 <- readPlaceholders $ untypeRelation a0 pempty + s1 <- readPlaceholders $ untypeRelation a1 pempty + return $ s0 `op` s1 -- | Union of two relations. union :: Relation () a -> Relation () a -> Relation () a @@ -177,34 +192,28 @@ intersect = liftAppend $ Syntax.intersect 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' :: (PersistableWidth p, PersistableWidth q) => 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' :: (PersistableWidth p, PersistableWidth q) => 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' :: (PersistableWidth p, PersistableWidth q) => 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' :: (PersistableWidth p, PersistableWidth q) => 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' :: (PersistableWidth p, PersistableWidth q) => 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' :: (PersistableWidth p, PersistableWidth q) => Relation p a -> Relation q a -> Relation (p, q) a intersectAll' = liftAppend' $ Syntax.intersect All infixl 7 `union`, `except`, `unionAll`, `exceptAll` diff --git a/relational-query/src/Database/Relational/SqlSyntax.hs b/relational-query/src/Database/Relational/SqlSyntax.hs index 4d123907..1e188c31 100644 --- a/relational-query/src/Database/Relational/SqlSyntax.hs +++ b/relational-query/src/Database/Relational/SqlSyntax.hs @@ -15,6 +15,7 @@ module Database.Relational.SqlSyntax ( module Database.Relational.SqlSyntax.Query, module Database.Relational.SqlSyntax.Fold, module Database.Relational.SqlSyntax.Updates, + module Database.Relational.SqlSyntax.Placeholders, ) where import Database.Relational.SqlSyntax.Types @@ -23,3 +24,4 @@ import Database.Relational.SqlSyntax.Aggregate import Database.Relational.SqlSyntax.Query import Database.Relational.SqlSyntax.Fold import Database.Relational.SqlSyntax.Updates +import Database.Relational.SqlSyntax.Placeholders diff --git a/relational-query/src/Database/Relational/SqlSyntax/Fold.hs b/relational-query/src/Database/Relational/SqlSyntax/Fold.hs index 3bd35749..048b92a8 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Fold.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Fold.hs @@ -23,7 +23,9 @@ module Database.Relational.SqlSyntax.Fold ( -- * Tuple and Record tupleFromJoinedSubQuery, - recordRawColumns, + typedTupleRawColumns, + + collectPlaceholderOffsets, -- * Query restriction composeWhere, composeHaving, @@ -42,7 +44,6 @@ 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 ((!)) @@ -51,13 +52,14 @@ import Database.Relational.Internal.String (StringSQL, stringSQL, rowStringSQL, showStringSQL, ) import qualified Database.Relational.Internal.Literal as Lit import Database.Relational.SqlSyntax.Types - (SubQuery (..), Record, Tuple, Predicate, + (SubQuery (..), TypedTuple, Tuple, Column (..), CaseClause(..), WhenClauses (..), NodeAttr (Just', Maybe), ProductTree (Leaf, Join), JoinProduct, Duplication (..), SetOp (..), BinOp (..), Qualifier (..), Qualified (..), AggregateBitKey (..), AggregateSet (..), AggregateElem (..), AggregateColumnRef, Order (..), Nulls (..), OrderingTerm, ) import qualified Database.Relational.SqlSyntax.Types as Syntax +import Database.Relational.SqlSyntax.Placeholders (detachPlaceholderOffsets, placeholderOffsets) -- | Compose duplication attribute string. @@ -100,8 +102,8 @@ 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 + d (Flat _ up _ _ _ _) = Syntax.tupleWidth $ detachPlaceholderOffsets up + d (Aggregated _ up _ _ _ _ _ _) = Syntax.tupleWidth $ detachPlaceholderOffsets up -- | Width of 'Qualified' 'SubQUery'. queryWidth :: Qualified SubQuery -> Int @@ -151,11 +153,17 @@ toSQLs = d where 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 + q = selectPrefixSQL (detachPlaceholderOffsets up) da + <> showsJoinProduct (productUnitSupport cf) (detachPlaceholderOffsets pd) + <> composeWhere (map detachPlaceholderOffsets rs) + <> composeOrderBy (detachPlaceholderOffsets 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 + q = selectPrefixSQL (detachPlaceholderOffsets up) da + <> showsJoinProduct (productUnitSupport cf) (detachPlaceholderOffsets pd) + <> composeWhere (map detachPlaceholderOffsets rs) + <> composeGroupBy (detachPlaceholderOffsets ag) + <> composeHaving (map detachPlaceholderOffsets grs) + <> composeOrderBy (detachPlaceholderOffsets od) showUnitSQL :: SubQuery -> StringSQL showUnitSQL = fst . toSQLs @@ -189,19 +197,37 @@ 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 + d (Flat _ up _ _ _ _) i = showTupleIndex (detachPlaceholderOffsets up) i + d (Aggregated _ up _ _ _ _ _ _) i = showTupleIndex (detachPlaceholderOffsets 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 +tupleFromJoinedSubQuery :: Qualified SubQuery -> Syntax.WithPlaceholderOffsets Tuple +tupleFromJoinedSubQuery qs = Syntax.withPlaceholderOffsets (collectPlaceholderOffsets s) $ d s where normalized = SubQueryRef <$> traverse (\q -> [0 .. width q - 1]) qs - d (Table _) = map RawColumn . map (column qs) - $ take (queryWidth qs) [0..] + s = Syntax.unQualify qs + d (Table _) = map RawColumn . map (column qs) $ take (queryWidth qs) [0..] d (Bin {}) = normalized d (Flat {}) = normalized d (Aggregated {}) = normalized +collectPlaceholderOffsets :: SubQuery -> Syntax.PlaceholderOffsets +collectPlaceholderOffsets = d where + d (Table _) = mempty + d (Flat _cfg tup _dup jp pds ots) = + placeholderOffsets tup + <> placeholderOffsets jp + <> foldMap placeholderOffsets pds + <> placeholderOffsets ots + d (Aggregated _cfg tup _dup jp pdfs aes pdas ots) = + placeholderOffsets tup + <> placeholderOffsets jp + <> foldMap placeholderOffsets pdfs + <> placeholderOffsets aes + <> foldMap placeholderOffsets pdas + <> placeholderOffsets ots + d (Bin _op sqx sqy) = collectPlaceholderOffsets sqx <> collectPlaceholderOffsets sqy + -- | index result of each when clause and else clause. indexWhensClause :: WhenClauses -> Int -> StringSQL indexWhensClause (WhenClauses ps e) i = @@ -236,13 +262,13 @@ showTupleIndex up i 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 +typedTupleRawColumns :: TypedTuple c r -- ^ Source 'Record' + -> [StringSQL] -- ^ Result SQL string list +typedTupleRawColumns = map showColumn . Syntax.untypeTuple -- | Show product tree of query into SQL. StringSQL result. -showsQueryProduct :: ProductTree [Predicate Flat] -> StringSQL +showsQueryProduct :: ProductTree [Tuple] -> StringSQL showsQueryProduct = rec where joinType Just' Just' = INNER joinType Just' Maybe = LEFT @@ -258,7 +284,7 @@ showsQueryProduct = rec where joinType (Syntax.nodeAttr left') (Syntax.nodeAttr right'), JOIN, urec right', ON, foldr1 SQL.and $ ps ++ concat [ pure $ Lit.bool True | null ps ] ] - where ps = [ rowStringSQL $ recordRawColumns p | p <- rs ] + where ps = [ rowStringSQL $ map showColumn p | p <- rs ] -- | Shows join product of query. showsJoinProduct :: ProductUnitSupport -> JoinProduct -> StringSQL @@ -269,17 +295,17 @@ showsJoinProduct ups = maybe (up ups) from where -- | Compose SQL String from 'QueryRestriction'. -composeRestrict :: Keyword -> [Predicate c] -> StringSQL +composeRestrict :: Keyword -> [Tuple] -> StringSQL composeRestrict k = d where d [] = mempty - d ps@(_:_) = k <> foldr1 SQL.and [ rowStringSQL $ recordRawColumns p | p <- ps ] + d ps@(_:_) = k <> foldr1 SQL.and [ rowStringSQL $ map showColumn p | p <- ps ] -- | Compose WHERE clause from 'QueryRestriction'. -composeWhere :: [Predicate Flat] -> StringSQL +composeWhere :: [Tuple] -> StringSQL composeWhere = composeRestrict WHERE -- | Compose HAVING clause from 'QueryRestriction'. -composeHaving :: [Predicate Aggregated] -> StringSQL +composeHaving :: [Tuple] -> StringSQL composeHaving = composeRestrict HAVING ----- diff --git a/relational-query/src/Database/Relational/SqlSyntax/Join.hs b/relational-query/src/Database/Relational/SqlSyntax/Join.hs index e4241f6f..848e868e 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Join.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Join.hs @@ -18,10 +18,8 @@ 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) + (NodeAttr (..), ProductTree (..), Node (..), Qualified, SubQuery,) -- | Push new tree into product right term. diff --git a/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs b/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs new file mode 100644 index 00000000..ea781e61 --- /dev/null +++ b/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs @@ -0,0 +1,91 @@ +module Database.Relational.SqlSyntax.Placeholders + ( -- * Manipulate placeholders referred in the statement. + withPlaceholderOffsets, + placeholderOffsets, + mapWithPlaceholderOffsets, + detachPlaceholderOffsets, + attachEmptyPlaceholderOffsets, + emptyPlaceholderOffsets, + sortByPlaceholderOffsets, + + -- ** Manipulate records with PlaceholderOffsets + record, + recordWidth, + untypeRecord, + placeholderOffsetsOfRecord, + isPlaceholdersRecord, + emptyPlaceholderOffsetsOfRecord, + tupleFromPlaceholderOffsets, + detachPlaceholderOffsetsOfRecord, + untypeRecordWithPlaceholderOffsets, + unsafeRecordFromTupleWithPlaceholderOffsets, + typeFromRawColumns, + + ) where + +import Control.Monad.Trans.Writer (writer, execWriter, runWriter, mapWriter) +import Data.Array (listArray, (!)) +import Data.DList (toList) + +import Database.Relational.Internal.String (StringSQL) +import Database.Relational.SqlSyntax.Types + (Record (Record), PlaceholderOffsets, WithPlaceholderOffsets, WithPlaceholderOffsetsT (WithPlaceholderOffsetsT), + Tuple, TypedTuple (TypedTuple), Column (RawColumn ), + toTypedTuple, untypeTuple, withPlaceholderOffsets, tupleWidth,) + +mapWithPlaceholderOffsets + :: ((a, PlaceholderOffsets) -> (b, PlaceholderOffsets)) -> WithPlaceholderOffsets a -> WithPlaceholderOffsets b +mapWithPlaceholderOffsets f (WithPlaceholderOffsetsT w) = WithPlaceholderOffsetsT $ mapWriter f w + +placeholderOffsets :: WithPlaceholderOffsets a -> PlaceholderOffsets +placeholderOffsets (WithPlaceholderOffsetsT w) = execWriter w + +detachPlaceholderOffsets :: WithPlaceholderOffsets a -> a +detachPlaceholderOffsets (WithPlaceholderOffsetsT w) = fst $ runWriter w + +tupleFromPlaceholderOffsets :: WithPlaceholderOffsets a -> (a, PlaceholderOffsets) +tupleFromPlaceholderOffsets (WithPlaceholderOffsetsT w) = runWriter w + +attachEmptyPlaceholderOffsets :: a -> WithPlaceholderOffsets a +attachEmptyPlaceholderOffsets x = WithPlaceholderOffsetsT $ writer (x, mempty) + +emptyPlaceholderOffsets :: WithPlaceholderOffsets a -> WithPlaceholderOffsets a +emptyPlaceholderOffsets = attachEmptyPlaceholderOffsets . detachPlaceholderOffsets + +isPlaceholdersRecord :: Record c r -> Bool +isPlaceholdersRecord = (/= mempty) . placeholderOffsets . toTypedTuple + +placeholderOffsetsOfRecord :: Record c r -> PlaceholderOffsets +placeholderOffsetsOfRecord = placeholderOffsets . toTypedTuple + +emptyPlaceholderOffsetsOfRecord :: Record c r -> Record c r +emptyPlaceholderOffsetsOfRecord = Record . emptyPlaceholderOffsets . toTypedTuple + +detachPlaceholderOffsetsOfRecord :: Record c r -> TypedTuple c r +detachPlaceholderOffsetsOfRecord = detachPlaceholderOffsets . toTypedTuple + +sortByPlaceholderOffsets :: PlaceholderOffsets -> [a] -> [a] +sortByPlaceholderOffsets phos xs = map (ary !) $ toList phos + where ary = listArray (0, length xs) xs + +-- | Unsafely type 'Tuple' value to 'Record' type. +record :: PlaceholderOffsets -> Tuple -> Record c t +record phs = Record . withPlaceholderOffsets phs . TypedTuple + +recordWidth :: Record c r -> Int +recordWidth = tupleWidth . untypeRecord + +untypeRecord :: Record c r -> Tuple +untypeRecord = untypeTuple . detachPlaceholderOffsets . toTypedTuple + +-- | Unsafely generate 'Record' from SQL string list. +typeFromRawColumns :: PlaceholderOffsets + -> [StringSQL] -- ^ SQL string list specifies columns + -> Record c r -- ^ Result 'Record' +typeFromRawColumns phs = record phs . map RawColumn + +untypeRecordWithPlaceholderOffsets :: Record c t -> WithPlaceholderOffsets Tuple +untypeRecordWithPlaceholderOffsets = fmap untypeTuple . toTypedTuple + +unsafeRecordFromTupleWithPlaceholderOffsets :: WithPlaceholderOffsets Tuple -> Record c t +unsafeRecordFromTupleWithPlaceholderOffsets = Record . fmap TypedTuple diff --git a/relational-query/src/Database/Relational/SqlSyntax/Query.hs b/relational-query/src/Database/Relational/SqlSyntax/Query.hs index 625f3641..00021040 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Query.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Query.hs @@ -15,33 +15,34 @@ module Database.Relational.SqlSyntax.Query ( ) where import Database.Relational.Internal.Config (Config) -import Database.Relational.Internal.ContextType (Flat, Aggregated) import Database.Relational.SqlSyntax.Types (Duplication (..), SetOp (..), BinOp (..), OrderingTerm, AggregateElem, JoinProduct, Predicate, WhenClauses (..), CaseClause (..), SubQuery (..), - Column (..), Tuple, Record, record, untypeRecord, recordWidth, ) + Column (..), WithPlaceholderOffsets, Tuple, Record,) +import Database.Relational.SqlSyntax.Placeholders + (record, untypeRecord, recordWidth, placeholderOffsetsOfRecord,) -- | Unsafely generate flat 'SubQuery' from untyped components. flatSubQuery :: Config - -> Tuple + -> WithPlaceholderOffsets Tuple -> Duplication - -> JoinProduct - -> [Predicate Flat] - -> [OrderingTerm] + -> WithPlaceholderOffsets JoinProduct + -> [WithPlaceholderOffsets Tuple] + -> WithPlaceholderOffsets [OrderingTerm] -> SubQuery flatSubQuery = Flat -- | Unsafely generate aggregated 'SubQuery' from untyped components. aggregatedSubQuery :: Config - -> Tuple + -> WithPlaceholderOffsets Tuple -> Duplication - -> JoinProduct - -> [Predicate Flat] - -> [AggregateElem] - -> [Predicate Aggregated] - -> [OrderingTerm] + -> WithPlaceholderOffsets JoinProduct + -> [WithPlaceholderOffsets Tuple] + -> WithPlaceholderOffsets [AggregateElem] + -> [WithPlaceholderOffsets Tuple] + -> WithPlaceholderOffsets [OrderingTerm] -> SubQuery aggregatedSubQuery = Aggregated @@ -78,9 +79,12 @@ 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] ] + record + (ws' <> placeholderOffsetsOfRecord e) + [ Case c i | i <- [0 .. recordWidth e - 1] ] where c = CaseSearch $ whenClauses "caseSearch" ws e + ws' = foldMap (\(wa, wb) -> placeholderOffsetsOfRecord wa <> placeholderOffsetsOfRecord wb) ws -- | Simple case operator correnponding SQL simple /CASE/. -- Like, /CASE x WHEN v THEN a WHEN w THEN b ... ELSE c END/ @@ -89,6 +93,9 @@ case' :: Record c a -- ^ Record value to match -> Record c b -- ^ Else result record -> Record c b -- ^ Result record case' v ws e = - record [ Case c i | i <- [0 .. recordWidth e - 1] ] + record + (placeholderOffsetsOfRecord v <> ws' <> placeholderOffsetsOfRecord e) + [ Case c i | i <- [0 .. recordWidth e - 1] ] where c = CaseSimple (untypeRecord v) $ whenClauses "case'" ws e + ws' = foldMap (\(wa, wb) -> placeholderOffsetsOfRecord wa <> placeholderOffsetsOfRecord wb) ws diff --git a/relational-query/src/Database/Relational/SqlSyntax/Types.hs b/relational-query/src/Database/Relational/SqlSyntax/Types.hs index 659acd25..5b17a3c0 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Types.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Types.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module : Database.Relational.SqlSyntax.Types @@ -39,21 +40,36 @@ module Database.Relational.SqlSyntax.Types ( -- * Column, Tuple, Record and Projection Column (..), Tuple, tupleWidth, - Record, untypeRecord, record, PI, - recordWidth, - typeFromRawColumns, - typeFromScalarSubQuery, + TypedTuple (TypedTuple), untypeTuple, + Record (Record), toTypedTuple, forciblyTypeTuple, mapTypedTuple, PI, -- * Predicate to restrict Query result Predicate, + + -- * Manipulate placeholders referred in the statement. + PlaceholderOffsets, + WithPlaceholderOffsetsT (WithPlaceholderOffsetsT), + WithPlaceholderOffsets, + SQLWithPlaceholderOffsets', + SQLWithPlaceholderOffsets, + + appendPlaceholderOffsets, + withPlaceholderOffsets, + runWithPlaceholderOffsetsT, + ) where import Prelude hiding (and, product) +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Trans.Writer (WriterT, runWriterT, writer, tell) +import Data.DList (DList) import Data.Foldable (Foldable) +import Data.Functor.Identity (Identity) +import Data.Monoid (Monoid, mempty) +import Data.Semigroup (Semigroup, (<>)) 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) @@ -96,16 +112,16 @@ data AggregateElem = ColumnRef AggregateColumnRef deriving Show -- | Typeful aggregate element. -newtype AggregateKey a = AggregateKey (a, AggregateElem) +newtype AggregateKey a = AggregateKey (a, AggregateElem) deriving Functor -- | Sub-query type data SubQuery = Table Untyped | Flat Config - Tuple Duplication JoinProduct [Predicate Flat] - [OrderingTerm] + (WithPlaceholderOffsets Tuple) Duplication (WithPlaceholderOffsets JoinProduct) [WithPlaceholderOffsets Tuple] + (WithPlaceholderOffsets [OrderingTerm]) | Aggregated Config - Tuple Duplication JoinProduct [Predicate Flat] - [AggregateElem] [Predicate Aggregated] [OrderingTerm] + (WithPlaceholderOffsets Tuple) Duplication (WithPlaceholderOffsets JoinProduct) [WithPlaceholderOffsets Tuple] + (WithPlaceholderOffsets [AggregateElem]) [WithPlaceholderOffsets Tuple] (WithPlaceholderOffsets [OrderingTerm]) | Bin BinOp SubQuery SubQuery deriving Show @@ -151,7 +167,7 @@ nodeTree :: Node rs -> ProductTree rs nodeTree (Node _ t) = t -- | Type for join product of query. -type JoinProduct = Maybe (ProductTree [Predicate Flat]) +type JoinProduct = Maybe (ProductTree [Tuple]) -- | when clauses data WhenClauses = @@ -180,9 +196,13 @@ tupleWidth :: Tuple -> Int tupleWidth = length -- | Phantom typed record. Projected into Haskell record type 't'. +newtype TypedTuple c t = + TypedTuple + { untypeTuple :: Tuple {- ^ Discard record type -} } deriving Show + newtype Record c t = Record - { untypeRecord :: Tuple {- ^ Discard record type -} } deriving Show + { toTypedTuple :: WithPlaceholderOffsets (TypedTuple c t) } deriving Show -- | Type for predicate to restrict of query result. type Predicate c = Record c (Maybe Bool) @@ -190,19 +210,37 @@ 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 +mapTypedTuple :: (TypedTuple c t -> TypedTuple c' t') -> Record c t -> Record c' t' +mapTypedTuple f = Record . fmap f . toTypedTuple + +type PlaceholderOffsets = DList Int + +newtype WithPlaceholderOffsetsT m a = + WithPlaceholderOffsetsT (WriterT PlaceholderOffsets m a) + deriving (Show, Functor, Applicative, Monad, Foldable, Traversable, MonadTrans) + +appendPlaceholderOffsets :: Monad m => PlaceholderOffsets -> WithPlaceholderOffsetsT m () +appendPlaceholderOffsets = WithPlaceholderOffsetsT . tell + +type WithPlaceholderOffsets = WithPlaceholderOffsetsT Identity + +type SQLWithPlaceholderOffsets' = WithPlaceholderOffsets StringSQL + +type SQLWithPlaceholderOffsets = WithPlaceholderOffsets String + +-- I wish I could use DerivingVia... +instance Semigroup a => Semigroup (WithPlaceholderOffsets a) where + ma <> mb = (<>) <$> ma <*> mb + +instance Monoid a => Monoid (WithPlaceholderOffsets a) where + mempty = withPlaceholderOffsets mempty mempty --- | Width of 'Record'. -recordWidth :: Record c r -> Int -recordWidth = length . untypeRecord +withPlaceholderOffsets :: PlaceholderOffsets -> a -> WithPlaceholderOffsets a +withPlaceholderOffsets phs x = WithPlaceholderOffsetsT $ writer (x, phs) --- | Unsafely generate 'Record' from SQL string list. -typeFromRawColumns :: [StringSQL] -- ^ SQL string list specifies columns - -> Record c r -- ^ Result 'Record' -typeFromRawColumns = record . map RawColumn +runWithPlaceholderOffsetsT :: WithPlaceholderOffsetsT m a -> m (a, PlaceholderOffsets) +runWithPlaceholderOffsetsT (WithPlaceholderOffsetsT act) = runWriterT act --- | Unsafely generate 'Record' from scalar sub-query. -typeFromScalarSubQuery :: SubQuery -> Record c t -typeFromScalarSubQuery = record . (:[]) . Scalar +-- | Unsafely type 'Tuple' value to 'TypedTuple' type. +forciblyTypeTuple :: Tuple -> TypedTuple c t +forciblyTypeTuple = TypedTuple diff --git a/relational-query/src/Database/Relational/SqlSyntax/Updates.hs b/relational-query/src/Database/Relational/SqlSyntax/Updates.hs index 76015c8b..bf76465f 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Updates.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Updates.hs @@ -22,6 +22,7 @@ import Data.Monoid ((<>)) import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) import qualified Language.SQL.Keyword as SQL +import Database.Relational.SqlSyntax.Types (WithPlaceholderOffsets, SQLWithPlaceholderOffsets') import Database.Relational.Internal.String (StringSQL, rowConsStringSQL) @@ -36,13 +37,13 @@ type AssignTerm = StringSQL type Assignment = (AssignColumn, AssignTerm) -- | Compose SET clause from ['Assignment']. -composeSets :: [Assignment] -> StringSQL -composeSets as = assigns where +composeSets :: WithPlaceholderOffsets [Assignment] -> SQLWithPlaceholderOffsets' +composeSets as = assigns <$> assignList where assignList = foldr (\ (col, term) r -> (col .=. term) : r) - [] as - assigns | null assignList = error "Update assignment list is null!" - | otherwise = SET <> SQL.fold (|*|) assignList + [] <$> as + assigns asl | null asl = error "Update assignment list is null!" + | otherwise = SET <> SQL.fold (|*|) asl -- | Compose VALUES clause from a row of value expressions. composeChunkValues :: Int -- ^ record count per chunk @@ -57,20 +58,23 @@ composeChunkValues n0 vs = -- | Compose columns row and VALUES clause from a row of value expressions. composeChunkValuesWithColumns :: Int -- ^ record count per chunk - -> [Assignment] -- ^ - -> StringSQL -composeChunkValuesWithColumns sz as = - rowConsStringSQL cs <> composeChunkValues sz vs + -> WithPlaceholderOffsets [Assignment] -- ^ + -> SQLWithPlaceholderOffsets' +composeChunkValuesWithColumns sz asPhs = f <$> asPhs where - (cs, vs) = unzip as + f as = rowConsStringSQL cs <> composeChunkValues sz vs + where + (cs, vs) = unzip as -- | Compose columns row and VALUES clause from rows list of value expressions. -composeValuesListWithColumns :: [[Assignment]] - -> StringSQL -composeValuesListWithColumns pss = - rowConsStringSQL cs <> VALUES <> SQL.fold (|*|) (map rowConsStringSQL vss) +composeValuesListWithColumns :: [WithPlaceholderOffsets [Assignment]] + -> SQLWithPlaceholderOffsets' +composeValuesListWithColumns pss = f <$> csPhs <*> vssPhs where - cs = case pss of + f cs vss = rowConsStringSQL cs <> VALUES <> SQL.fold (|*|) (map rowConsStringSQL vss) + csPhs :: WithPlaceholderOffsets [AssignColumn] + csPhs = case pss of [] -> error "insertValueList: no assignment chunks" - ps:_ -> fst $ unzip ps - vss = map (snd . unzip) pss + ps:_ -> fst . unzip <$> ps + vssPhs :: WithPlaceholderOffsets [[AssignTerm]] + vssPhs = traverse (fmap (snd . unzip)) pss diff --git a/relational-query/src/Database/Relational/TH.hs b/relational-query/src/Database/Relational/TH.hs index f044559e..8151699e 100644 --- a/relational-query/src/Database/Relational/TH.hs +++ b/relational-query/src/Database/Relational/TH.hs @@ -87,6 +87,7 @@ import Database.Record.TH (columnOffsetsVarNameDefault, recordTypeName, recordTemplate, defineRecordTypeWithConfig, defineHasColumnConstraintInstance) import qualified Database.Record.TH as Record +import Database.Record.Persistable (PersistableWidth) import Database.Relational (Table, Pi, id', Relation, LiteralSQL, @@ -95,8 +96,9 @@ import Database.Relational schemaNameMode, nameConfig, identifierQuotation), Query, untypeQuery, relationalQuery_, relationalQuery, KeyUpdate, Insert, insert, InsertQuery, insertQuery, - HasConstraintKey(constraintKey), Primary, NotNull, primarySelect, primaryUpdate) + HasConstraintKey(constraintKey), Primary, NotNull, primarySelect, primaryUpdate,) +import Database.Relational.SqlSyntax (attachEmptyPlaceholderOffsets, detachPlaceholderOffsets,) import Database.Relational.InternalTH.Base (defineTuplePi, defineRecordProjections) import Database.Relational.Scalar (defineScalarDegree) import Database.Relational.Constraint (unsafeDefineConstraintKey) @@ -224,7 +226,7 @@ defineTableDerivations tableVar' relVar' insVar' insQVar' recordType' = do insDs <- simpleValD insVar [t| Insert $recordType' |] [| insert id' |] let insQVar = varName insQVar' - insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType' -> InsertQuery p |] + insQDs <- simpleValD insQVar [t| forall p. PersistableWidth p => Relation p $recordType' -> InsertQuery p |] [| insertQuery id' |] return $ concat [tableDs, relDs, insDs, insQDs] @@ -434,7 +436,7 @@ unsafeInlineQuery :: TypeQ -- ^ Query parameter type unsafeInlineQuery p r sql qVar' = simpleValD (varName qVar') [t| Query $p $r |] - [| unsafeTypedQuery $(stringE sql) |] + [| unsafeTypedQuery $ attachEmptyPlaceholderOffsets $(stringE sql) |] {-# DEPRECATED unsafeInlineQuery "will be dropped in future releases." #-} -- | Extract param type and result type from defined Relation @@ -448,7 +450,8 @@ reifyRelation relVar = do _ -> fail $ "expandRelation: Variable must have Relation type: " ++ show relVar -inlineQuery_ :: (String -> Q ()) -- ^ action to check SQL string +inlineQuery_ :: PersistableWidth p + => (String -> Q ()) -- ^ action to check SQL string -> Name -- ^ Top-level variable name which has 'Relation' type -> Relation p r -- ^ Object which has 'Relation' type -> Config -- ^ Configuration to generate SQL @@ -456,16 +459,18 @@ inlineQuery_ :: (String -> Q ()) -- ^ action to check SQL string -> String -- ^ Variable name to define as inlined query -> Q [Dec] -- ^ Result declarations inlineQuery_ check relVar rel config sufs declName = do - let sql = untypeQuery $ relationalQuery_ config rel sufs + let sql = detachPlaceholderOffsets . untypeQuery $ relationalQuery_ config rel sufs check sql (p, r) <- reifyRelation relVar simpleValD (varName $ varCamelcaseName declName) [t| Query $(return p) $(return r) |] [| unsafeTypedQuery + $ attachEmptyPlaceholderOffsets $(stringE sql) |] -- | Inlining composed 'Query' in compile type. -inlineQuery :: Name -- ^ Top-level variable name which has 'Relation' type +inlineQuery :: PersistableWidth p + => Name -- ^ Top-level variable name which has 'Relation' type -> Relation p r -- ^ Object which has 'Relation' type -> Config -- ^ Configuration to generate SQL -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... diff --git a/relational-query/src/Database/Relational/Type.hs b/relational-query/src/Database/Relational/Type.hs index 74e77fbf..c179bdeb 100644 --- a/relational-query/src/Database/Relational/Type.hs +++ b/relational-query/src/Database/Relational/Type.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | -- Module : Database.Relational.Type -- Copyright : 2013-2019 Kei Hibino @@ -59,18 +61,19 @@ module Database.Relational.Type ( derivedDelete', derivedDelete, ) where +import Data.Coerce (coerce) +import Data.DList (fromList) import Data.Monoid ((<>), mconcat) -import Data.Functor.ProductIsomorphic (peRight) import Language.SQL.Keyword (Keyword) -import Database.Record (PersistableWidth) +import Database.Record (PersistableWidth, PersistableRecordWidth, derivedWidth) import Database.Relational.Internal.Config (Config, defaultConfig) import Database.Relational.Internal.ContextType (Flat) import Database.Relational.Internal.String (showStringSQL) -import Database.Relational.SqlSyntax (Record) +import Database.Relational.SqlSyntax (Record, SQLWithPlaceholderOffsets, withPlaceholderOffsets, detachPlaceholderOffsets) -import Database.Relational.Monad.BaseType (Relation, sqlFromRelationWith) +import Database.Relational.Monad.BaseType (Relation, sqlFromRelationWith, defaultPlaceholders) import Database.Relational.Monad.Restrict (Restrict) import Database.Relational.Monad.Assign (Assign) import Database.Relational.Monad.Register (Register) @@ -82,30 +85,31 @@ import Database.Relational.Effect import Database.Relational.Pi (Pi) import Database.Relational.Table (Table, TableDerivable, derivedTable) import Database.Relational.ProjectableClass (LiteralSQL) -import Database.Relational.Projectable (PlaceHolders, unitPH) import Database.Relational.SimpleSql (insertPrefixSQL, updateOtherThanKeySQL, ) +import Database.Relational.Monad.Trans.ReadPlaceholders (ReadPlaceholders,) -- | Query type with place-holder parameter 'p' and query result type 'a'. -newtype Query p a = Query { untypeQuery :: String } +newtype Query p a = Query { untypeQuery :: SQLWithPlaceholderOffsets } -- | Unsafely make typed 'Query' from SQL string. -unsafeTypedQuery :: String -- ^ Query SQL to type +unsafeTypedQuery :: SQLWithPlaceholderOffsets -- ^ Query SQL to type -> Query p a -- ^ Typed result unsafeTypedQuery = Query -- | Show query SQL string instance Show (Query p a) where - show = untypeQuery + show = detachPlaceholderOffsets . untypeQuery -- | From 'Relation' into untyped SQL query string. -relationalQuerySQL :: Config -> Relation p r -> [Keyword] -> String +relationalQuerySQL :: PersistableWidth p => Config -> Relation p r -> [Keyword] -> SQLWithPlaceholderOffsets relationalQuerySQL config rel qsuf = - showStringSQL $ sqlFromRelationWith rel config <> mconcat qsuf + showStringSQL . (<> mconcat qsuf) <$> sqlFromRelationWith rel defaultPlaceholders config -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery_ :: Config +relationalQuery_ :: PersistableWidth p + => Config -> Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query @@ -113,13 +117,15 @@ relationalQuery_ config rel qsuf = unsafeTypedQuery $ relationalQuerySQL config rel qsuf -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery' :: Relation p r -- ^ relation to finalize building +relationalQuery' :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery' = relationalQuery_ defaultConfig -- | From 'Relation' into typed 'Query'. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> Query p r -- ^ finalized query relationalQuery = (`relationalQuery'` []) @@ -128,121 +134,124 @@ relationalQuery = (`relationalQuery'` []) -- 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 + , untypeKeyUpdate :: SQLWithPlaceholderOffsets } -- | Unsafely make typed 'KeyUpdate' from SQL string. -unsafeTypedKeyUpdate :: Pi a p -> String -> KeyUpdate p a +unsafeTypedKeyUpdate :: Pi a p -> SQLWithPlaceholderOffsets -> 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 +typedKeyUpdate :: forall a p. PersistableWidth p => Table a -> Pi a p -> KeyUpdate p a +typedKeyUpdate tbl key = + unsafeTypedKeyUpdate key . withPlaceholderOffsets phs $ updateOtherThanKeySQL tbl key + where + phs = fromList [0 .. (snd (derivedWidth :: (PersistableRecordWidth p, Int)) - 1)] -- | Make typed 'KeyUpdate' object using derived info specified by 'Relation' type. -typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r +typedKeyUpdateTable :: (PersistableWidth p, TableDerivable r) => Relation () r -> Pi r p -> KeyUpdate p r typedKeyUpdateTable = typedKeyUpdate . tableOf -- keyUpdate' -- Config parameter is not yet required for KeyUpdate. -- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'. -keyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r +keyUpdate :: (PersistableWidth p, TableDerivable r) => Pi r p -> KeyUpdate p r keyUpdate = typedKeyUpdate derivedTable {-# DEPRECATED derivedKeyUpdate "use keyUpdate instead of this." #-} -- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'. -derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r +derivedKeyUpdate :: (PersistableWidth p, TableDerivable r) => Pi r p -> KeyUpdate p r derivedKeyUpdate = keyUpdate -- | Show update SQL string instance Show (KeyUpdate p a) where - show = untypeKeyUpdate + show = detachPlaceholderOffsets . untypeKeyUpdate -- | Update type with place-holder parameter 'p'. -newtype Update p = Update { untypeUpdate :: String } +newtype Update p = Update { untypeUpdate :: SQLWithPlaceholderOffsets } -- | Unsafely make typed 'Update' from SQL string. -unsafeTypedUpdate :: String -> Update p +unsafeTypedUpdate :: SQLWithPlaceholderOffsets -> Update p unsafeTypedUpdate = Update -- | Make untyped update SQL string from 'Table' and 'Assign' computation. -updateSQL :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> String -updateSQL config tbl ut = showStringSQL $ updateFromUpdateTarget config tbl ut +updateSQL :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> SQLWithPlaceholderOffsets +updateSQL config tbl ut = showStringSQL <$> updateFromUpdateTarget config tbl ut -- | Make typed 'Update' from 'Config', 'Table' and 'Assign' computation. -typedUpdate' :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p +typedUpdate' :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p typedUpdate' config tbl ut = unsafeTypedUpdate $ updateSQL config tbl ut {-# DEPRECATED typedUpdate "use `typedUpdate' defaultConfig` instead of this." #-} -- | Make typed 'Update' using 'defaultConfig', 'Table' and 'Assign' computation. -typedUpdate :: Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p +typedUpdate :: PersistableWidth p => Table r -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p typedUpdate = typedUpdate' defaultConfig -targetTable :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Table r +targetTable :: TableDerivable r => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Table r targetTable = const derivedTable -- | Make typed 'Update' from 'Config', derived table and 'Assign' computation. -update' :: TableDerivable r => Config -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p +update' :: PersistableWidth p => TableDerivable r => Config -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update' config ac = typedUpdate' config (targetTable ac) ac {-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-} -- | Make typed 'Update' from 'Config', derived table and 'Assign' computation. -derivedUpdate' :: TableDerivable r => Config -> (Record Flat r -> Assign r (PlaceHolders p)) -> Update p +derivedUpdate' :: (PersistableWidth p, TableDerivable r) => Config -> (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p derivedUpdate' = update' -- | Make typed 'Update' from 'defaultConfig', derived table and 'Assign' computation. -update :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Update p +update :: (PersistableWidth p, TableDerivable r) => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' defaultConfig -- | Make typed 'Update' from 'defaultConfig', derived table and 'Assign' computation with no(unit) placeholder. -updateNoPH :: TableDerivable r => (Record Flat r -> Assign r ()) -> Update () -updateNoPH af = update $ (>> return unitPH) . af +updateNoPH :: TableDerivable r => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () +updateNoPH = update {-# DEPRECATED derivedUpdate "use `update` instead of this." #-} -- | Make typed 'Update' from 'defaultConfig', derived table and 'Assign' computation. -derivedUpdate :: TableDerivable r => (Record Flat r -> Assign r (PlaceHolders p)) -> Update p +derivedUpdate :: (PersistableWidth p, TableDerivable r) => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p derivedUpdate = update -- | Make typed 'Update' from 'Config', 'Table' and 'Restrict' computation. -- Update target is all column. -typedUpdateAllColumn' :: PersistableWidth r +typedUpdateAllColumn' :: (PersistableWidth p, PersistableWidth r) => Config -> Table r - -> (Record Flat r -> Restrict (PlaceHolders p)) + -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Update (r, p) typedUpdateAllColumn' config tbl r = typedUpdate' config tbl $ liftTargetAllColumn' r -- | Make typed 'Update' from 'Table' and 'Restrict' computation. -- Update target is all column. -typedUpdateAllColumn :: PersistableWidth r +typedUpdateAllColumn :: (PersistableWidth p, PersistableWidth r) => Table r - -> (Record Flat r -> Restrict (PlaceHolders p)) + -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Update (r, p) typedUpdateAllColumn = typedUpdateAllColumn' defaultConfig -- | Make typed 'Update' from 'Config', derived table and 'Restrict' computation. -- Update target is all column. -updateAllColumn' :: (PersistableWidth r, TableDerivable r) +updateAllColumn' :: (PersistableWidth p, PersistableWidth r, TableDerivable r) => Config - -> (Record Flat r -> Restrict (PlaceHolders p)) + -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Update (r, p) updateAllColumn' config = typedUpdateAllColumn' config derivedTable {-# DEPRECATED derivedUpdateAllColumn' "use `updateAllColumn'` instead of this." #-} -- | Deprecated. use 'updateAllColumn''. -derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r) +derivedUpdateAllColumn' :: (PersistableWidth p, PersistableWidth r, TableDerivable r) => Config - -> (Record Flat r -> Restrict (PlaceHolders p)) + -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Update (r, p) derivedUpdateAllColumn' = updateAllColumn' -- | Make typed 'Update' from 'defaultConfig', derived table and 'Restrict' computation. -- Update target is all column. -updateAllColumn :: (PersistableWidth r, TableDerivable r) - => (Record Flat r -> Restrict (PlaceHolders p)) +updateAllColumn :: (PersistableWidth p, PersistableWidth r, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Update (r, p) updateAllColumn = updateAllColumn' defaultConfig @@ -250,32 +259,32 @@ updateAllColumn = updateAllColumn' defaultConfig -- without placeholder other than target table columns. -- Update target is all column. updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r) - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Update r updateAllColumnNoPH = - typedUpdate' defaultConfig derivedTable . (fmap peRight .) . liftTargetAllColumn' . ((>> return unitPH) .) + coerce . typedUpdate' defaultConfig derivedTable . liftTargetAllColumn' {-# DEPRECATED derivedUpdateAllColumn "use `updateAllColumn` instead of this." #-} -- | Deprecated. use 'updateAllColumn'. -derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r) - => (Record Flat r -> Restrict (PlaceHolders p)) +derivedUpdateAllColumn :: (PersistableWidth p, PersistableWidth r, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Update (r, p) derivedUpdateAllColumn = updateAllColumn -- | Show update SQL string instance Show (Update p) where - show = untypeUpdate + show = detachPlaceholderOffsets . untypeUpdate -- | Insert type to insert record type 'a'. data Insert a = Insert - { untypeInsert :: String - , chunkedInsert :: Maybe (String, Int) + { untypeInsert :: SQLWithPlaceholderOffsets + , chunkedInsert :: Maybe (SQLWithPlaceholderOffsets, Int) } -- | Statement to use chunked insert -untypeChunkInsert :: Insert a -> String +untypeChunkInsert :: Insert a -> SQLWithPlaceholderOffsets untypeChunkInsert ins = maybe (untypeInsert ins) fst $ chunkedInsert ins -- | Size to use chunked insert @@ -283,69 +292,69 @@ 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' :: SQLWithPlaceholderOffsets -> SQLWithPlaceholderOffsets -> Int -> Insert a unsafeTypedInsert' s = curry (Insert s . Just) -- | Unsafely make typed 'Insert' from single insert SQL. -unsafeTypedInsert :: String -> Insert a +unsafeTypedInsert :: SQLWithPlaceholderOffsets -> 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' :: (PersistableWidth r', TableDerivable r) => Config -> Table r -> Pi r r' -> Insert r' typedInsert' config tbl = typedInsertValue' config tbl . insertTarget' . piRegister {-# DEPRECATED typedInsert "use `typedInsert' defaultConfig` instead of this." #-} -- | Make typed 'Insert' from 'Table' and columns selector 'Pi'. -typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r' +typedInsert :: (PersistableWidth r', TableDerivable r) => Table r -> Pi r r' -> Insert r' typedInsert = typedInsert' defaultConfig -- | Table type inferred 'Insert'. -insert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' +insert :: (PersistableWidth r', PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' insert = typedInsert' defaultConfig derivedTable {-# DEPRECATED derivedInsert "use `insert` instead of this." #-} -- | Table type inferred 'Insert'. -derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' +derivedInsert :: (PersistableWidth r', PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r' derivedInsert = insert -- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. -typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p +typedInsertValue' :: PersistableWidth p => Config -> Table r -> InsertTarget p r -> Insert p typedInsertValue' config tbl it = unsafeTypedInsert' - (showStringSQL $ sqlFromInsertTarget config tbl it) - (showStringSQL ci) n + (showStringSQL <$> sqlFromInsertTarget config defaultPlaceholders tbl it) + (showStringSQL <$> ci) n where - (ci, n) = sqlChunkFromInsertTarget config tbl it + (ci, n) = sqlChunkFromInsertTarget config defaultPlaceholders tbl it {-# DEPRECATED typedInsertValue "use `typedInsertValue' defaultConfig` instead of this." #-} -- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object. -typedInsertValue :: Table r -> InsertTarget p r -> Insert p +typedInsertValue :: PersistableWidth p => Table r -> InsertTarget p r -> Insert p typedInsertValue = typedInsertValue' defaultConfig -- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. -insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p +insertValue' :: PersistableWidth p => TableDerivable r => Config -> ReadPlaceholders p (Register r) () -> Insert p insertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs where - rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r + rt :: TableDerivable r => ReadPlaceholders p (Register r) () -> Table r rt = const derivedTable {-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-} -- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object. -derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p +derivedInsertValue' :: PersistableWidth p => TableDerivable r => Config -> ReadPlaceholders p (Register r) () -> Insert p derivedInsertValue' = insertValue' -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p +insertValue :: (PersistableWidth p, TableDerivable r) => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' defaultConfig -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object with no(unit) placeholder. -insertValueNoPH :: TableDerivable r => Register r () -> Insert () -insertValueNoPH = insertValue . (>> return unitPH) +insertValueNoPH :: TableDerivable r => ReadPlaceholders () (Register r) () -> Insert () +insertValueNoPH = insertValue {-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-} -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. -derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p +derivedInsertValue :: (PersistableWidth p, TableDerivable r) => ReadPlaceholders p (Register r) () -> Insert p derivedInsertValue = insertValue -- | Make typed 'Insert' list from 'Config' and records list. @@ -355,7 +364,7 @@ insertValueList' :: (TableDerivable r, LiteralSQL r') -> [r'] -> [Insert ()] insertValueList' config pi' = - map (unsafeTypedInsert . showStringSQL) + map (unsafeTypedInsert . fmap showStringSQL) . sqlChunksFromRecordList config derivedTable pi' -- | Make typed 'Insert' list from records list. @@ -367,100 +376,100 @@ insertValueList = insertValueList' defaultConfig -- | Show insert SQL string. instance Show (Insert a) where - show = untypeInsert + show = detachPlaceholderOffsets . untypeInsert -- | InsertQuery type. -newtype InsertQuery p = InsertQuery { untypeInsertQuery :: String } +newtype InsertQuery p = InsertQuery { untypeInsertQuery :: SQLWithPlaceholderOffsets } -- | Unsafely make typed 'InsertQuery' from SQL string. -unsafeTypedInsertQuery :: String -> InsertQuery p +unsafeTypedInsertQuery :: SQLWithPlaceholderOffsets -> 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 +insertQuerySQL :: PersistableWidth p => Config -> Table r -> Pi r r' -> Relation p r' -> SQLWithPlaceholderOffsets +insertQuerySQL config tbl pi' rel = showStringSQL . (insertPrefixSQL pi' tbl <>) <$> sqlFromRelationWith rel defaultPlaceholders 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 +typedInsertQuery' :: PersistableWidth p => Config -> Table r -> Pi r r' -> Relation p r' -> InsertQuery p +typedInsertQuery' config tbl pi' = unsafeTypedInsertQuery . insertQuerySQL config tbl pi' {-# DEPRECATED typedInsertQuery "use `typedInsertQuery' defaultConfig` instead of this." #-} -- | Make typed 'InsertQuery' from columns selector 'Table', 'Pi' and 'Relation'. -typedInsertQuery :: Table r -> Pi r r' -> Relation p r' -> InsertQuery p -typedInsertQuery = typedInsertQuery' defaultConfig +typedInsertQuery :: PersistableWidth p => Table r -> Pi r r' -> Relation p r' -> InsertQuery p +typedInsertQuery = typedInsertQuery' defaultConfig -- | Table type inferred 'InsertQuery'. -insertQuery' :: TableDerivable r => Config -> Pi r r' -> Relation p r' -> InsertQuery p +insertQuery' :: (PersistableWidth p, TableDerivable r) => Config -> Pi r r' -> Relation p r' -> InsertQuery p insertQuery' config = typedInsertQuery' config derivedTable -- | Table type inferred 'InsertQuery' with 'defaultConfig'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' defaultConfig {-# DEPRECATED derivedInsertQuery "use `insertQuery` instead of this." #-} -- | Table type inferred 'InsertQuery'. -derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +derivedInsertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p derivedInsertQuery = insertQuery -- | Show insert SQL string. instance Show (InsertQuery p) where - show = untypeInsertQuery + show = detachPlaceholderOffsets . untypeInsertQuery -- | Delete type with place-holder parameter 'p'. -newtype Delete p = Delete { untypeDelete :: String } +newtype Delete p = Delete { untypeDelete :: SQLWithPlaceholderOffsets } -- | Unsafely make typed 'Delete' from SQL string. -unsafeTypedDelete :: String -> Delete p +unsafeTypedDelete :: SQLWithPlaceholderOffsets -> Delete p unsafeTypedDelete = Delete -- | Make untyped delete SQL string from 'Table' and 'Restrict' computation. -deleteSQL :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> String -deleteSQL config tbl r = showStringSQL $ deleteFromRestriction config tbl r +deleteSQL :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> SQLWithPlaceholderOffsets +deleteSQL config tbl r = showStringSQL <$> deleteFromRestriction config tbl r -- | Make typed 'Delete' from 'Config', 'Table' and 'Restrict' computation. -typedDelete' :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p +typedDelete' :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p typedDelete' config tbl r = unsafeTypedDelete $ deleteSQL config tbl r {-# DEPRECATED typedDelete "use `typedDelete' defaultConfig` instead of this." #-} -- | Make typed 'Delete' from 'Table' and 'Restrict' computation. -typedDelete :: Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p +typedDelete :: PersistableWidth p => Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p typedDelete = typedDelete' defaultConfig -restrictedTable :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Table r +restrictedTable :: TableDerivable r => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Table r restrictedTable = const derivedTable -- | Make typed 'Delete' from 'Config', derived table and 'Restrict' computation. -delete' :: TableDerivable r => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p +delete' :: PersistableWidth p => TableDerivable r => Config -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete' config rc = typedDelete' config (restrictedTable rc) rc {-# DEPRECATED derivedDelete' "use `delete'` instead of this." #-} -- | Make typed 'Delete' from 'Config', derived table and 'Restrict' computation. -derivedDelete' :: TableDerivable r => Config -> (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p +derivedDelete' :: (PersistableWidth p, TableDerivable r) => Config -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p derivedDelete' = delete' -- | Make typed 'Delete' from 'defaultConfig', derived table and 'Restrict' computation. -delete :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p +delete :: (PersistableWidth p, TableDerivable r) => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' defaultConfig -- | Make typed 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. -deleteNoPH :: TableDerivable r => (Record Flat r -> Restrict ()) -> Delete () -deleteNoPH rf = delete $ (>> return unitPH) . rf +deleteNoPH :: TableDerivable r => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () +deleteNoPH = delete {-# DEPRECATED derivedDelete "use `delete` instead of this." #-} -- | Make typed 'Delete' from 'defaultConfig', derived table and 'Restrict' computation. -derivedDelete :: TableDerivable r => (Record Flat r -> Restrict (PlaceHolders p)) -> Delete p +derivedDelete :: (PersistableWidth p, TableDerivable r) => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p derivedDelete = delete -- | Show delete SQL string instance Show (Delete p) where - show = untypeDelete + show = detachPlaceholderOffsets . 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 + untypeNoFetch :: s p -> SQLWithPlaceholderOffsets instance UntypeableNoFetch Insert where untypeNoFetch = untypeInsert diff --git a/relational-query/test/sqlsEq.hs b/relational-query/test/sqlsEq.hs index 6acc1ab2..8ff04609 100644 --- a/relational-query/test/sqlsEq.hs +++ b/relational-query/test/sqlsEq.hs @@ -7,6 +7,7 @@ import Conflict (conflictB) import qualified Conflict as B import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (first) import Data.Functor.ProductIsomorphic ((|$|), (|*|)) import Data.Int (Int32, Int64) @@ -47,7 +48,7 @@ wheresX :: Relation () (SetA, SetB) wheresX = relation $ do a <- query setA b <- query setB - wheres $ b ! intB0' .>=. value 3 + wheres $ b ! intB0' .>=. toFlat (value 3) return $ (,) |$| a |*| b groupByX :: Relation () (Int32, Integer) @@ -60,7 +61,7 @@ havingX :: Relation () Int havingX = aggregateRelation $ do a <- query setA let c = count (a ! intA0') - having $ c .>. value 1 + having $ c .>. toAggregated (value 1) return c distinctX :: Relation () Int32 @@ -81,11 +82,11 @@ assignX = updateNoPH $ \_proj -> registerX :: Insert (String, Maybe String) registerX = insertValue $ do - intC0' <-# value 1 - (ph1, ()) <- placeholder (\ph' -> strC1' <-# ph') - intC2' <-# value 2 - (ph2, ()) <- placeholder (\ph' -> mayStrC3' <-# ph') - return $ ph1 >< ph2 + ph <- askPlaceholders + intC0' <-# toFlat (value 1) + strC1' <-# toFlat (ph ! fst') + intC2' <-# toFlat (value 2) + mayStrC3' <-# toFlat (ph ! snd') eqChunkedInsert :: String -> Insert a @@ -101,6 +102,7 @@ eqChunkedInsert name ins prefix row = $ prefix : replicate (n - 1) (row ++ ",") ++ [row] in eqProp' name id sql estimate) + . fmap (first detachPlaceholderOffsets) $ chunkedInsert ins where success = QSimple.Bool Nothing True @@ -240,21 +242,21 @@ nestedPiRec :: Relation () SetA nestedPiRec = relation $ do ar <- query . relation $ do a <- query setA - return $ value "Hello" >< a + return $ toFlat (value "Hello") >< a return $ ar ! snd' nestedPiCol :: Relation () String nestedPiCol = relation $ do ar <- query . relation $ do a <- query setA - return $ a >< value "Hello" + return $ a >< toFlat (value "Hello") return $ ar ! snd' nestedPi :: Relation () String nestedPi = relation $ do ar <- query . relation $ do a <- query setA - return $ (value "Hello" >< a) >< value "World" + return $ (toFlat (value "Hello") >< a) >< toFlat (value "World") return $ ar ! snd' nested :: [Test] @@ -286,24 +288,24 @@ _p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] -- Record Operators bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> Relation () r -bin53 op = relation $ do - return $ value 5 `op` value 3 +bin53 op = relation $ + return (toFlat (value 5) `op` toFlat (value 3)) strIn :: Relation () (Maybe Bool) strIn = relation $ - return $ value "foo" `in'` values ["foo", "bar"] + return . toFlat $ value "foo" `in'` values ["foo", "bar"] boolTF :: (Record Flat (Maybe Bool) -> Record Flat (Maybe Bool) -> Record Flat r) -> Relation () r -boolTF op = relation $ do - return $ valueTrue `op` valueFalse +boolTF op = relation $ + return $ toFlat valueTrue `op` toFlat valueFalse strConcat :: Relation () String strConcat = relation $ do - return $ value "Hello, " .||. value "World!" + return . toFlat $ value "Hello, " .||. value "World!" strLike :: Relation () (Maybe Bool) strLike = relation $ do - return $ value "Hoge" `like` "H%" + return . toFlat $ value "Hoge" `like` "H%" _p_bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> IO () _p_bin53 = print . bin53 @@ -333,7 +335,7 @@ bin = caseSearchX :: Relation () String caseSearchX = relation $ do - return $ + return . toFlat $ caseSearch [ (value 2 .=. value (1 :: Int32) , value "foo") , (value 5 .=. value 3 .+. value (2 :: Int32) , value "bar") @@ -342,7 +344,7 @@ caseSearchX = relation $ do caseX :: Relation () String caseX = relation $ do - return $ + return . toFlat $ case' (value (5 :: Int32)) [ (value 1 , value "foo") @@ -352,7 +354,7 @@ caseX = relation $ do caseRecordX :: Relation () Int32 caseRecordX = relation $ do - return $ + return . toFlat $ case' (value (5 :: Int32)) [ (value 1 , (,) |$| value 1 |*| value "foo") @@ -365,7 +367,7 @@ caseRecordX = relation $ do caseRecordMaybeX :: Relation () (Maybe (Int32, String)) caseRecordMaybeX = relation $ do - return $ + return . toFlat $ caseMaybe (value (5 :: Int32)) [ (value (1 :: Int32) , just $ (,) |$| value (1 :: Int32) |*| value "foo") @@ -393,7 +395,7 @@ nothingX = relation $ do a <- query setA b <- queryMaybe setB - wheres $ isNothing b `or'` a ! intA0' .=. value 1 + wheres $ isNothing b `or'` a ! intA0' .=. toFlat (value 1) return $ a >< b @@ -402,7 +404,7 @@ justX = relation $ do a <- query setA b <- queryMaybe setB - wheres $ isJust b `or'` a ! intA0' .=. value 1 + wheres $ isJust b `or'` a ! intA0' .=. toFlat (value 1) return $ a >< b @@ -413,11 +415,11 @@ maybeX = relation $ do wheres $ a ?! strA2' .=. b ! mayStrB1' - return $ fromMaybe (value 1) (a ?! intA0') >< b + return $ fromMaybe (toFlat $ value 1) (a ?! intA0') >< b notX :: Relation () (Maybe Bool) notX = relation $ - return $ not' valueFalse + return $ not' (toFlat valueFalse) existsX :: Relation () (Maybe Bool) existsX = relation $ @@ -636,11 +638,11 @@ updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = updateNoPH $ \proj -> do strA2' <-# value "X" - wheres $ proj ! strA1' .=. value "A" + wheres $ proj ! strA1' .=. toFlat (value "A") deleteX :: Delete () deleteX = deleteNoPH $ \proj -> - wheres $ proj ! strA1' .=. value "A" + wheres $ proj ! strA1' .=. toFlat (value "A") effs :: [Test] effs = @@ -676,7 +678,7 @@ updateScalarX = updateNoPH $ \proj -> do strA2' <-# value "X" sb <- queryScalar . unsafeUnique . relation $ do b <- query setB - wheres $ b ! intB0' .=. value 0 + wheres $ b ! intB0' .=. toFlat (value 0) return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb @@ -702,7 +704,7 @@ deleteScalarX :: Delete () deleteScalarX = deleteNoPH $ \proj -> do sb <- queryScalar . unsafeUnique . relation $ do b <- query setB - wheres $ b ! intB0' .=. value 0 + wheres $ b ! intB0' .=. toFlat (value 0) return $ b ! intB0' wheres $ just (proj ! intA0') .=. sb diff --git a/relational-query/test/sqlsEqArrow.hs b/relational-query/test/sqlsEqArrow.hs index c4cdf480..2bf26f20 100644 --- a/relational-query/test/sqlsEqArrow.hs +++ b/relational-query/test/sqlsEqArrow.hs @@ -6,7 +6,7 @@ import qualified Test.QuickCheck.Simple as QSimple import Lex (eqProp, eqProp') import Model -import Control.Arrow (returnA, arr, (<<<), (***)) +import Control.Arrow (first, returnA, arr, (<<<), (***)) import Data.Int (Int32, Int64) import Data.Functor.ProductIsomorphic ((|$|), (|*|)) @@ -46,7 +46,7 @@ wheresX :: Relation () (SetA, SetB) wheresX = relation $ proc () -> do a <- query setA -< () b <- query setB -< () - wheres -< b ! intB0' .>=. value 3 + wheres -< b ! intB0' .>=. toFlat (value 3) returnA -< (,) |$| a |*| b groupByX :: Relation () (Int32, Integer) @@ -59,7 +59,7 @@ havingX :: Relation () Int havingX = aggregateRelation $ proc () -> do a <- query setA -< () let c = count (a ! intA0') - having -< c .>. value 1 + having -< c .>. toAggregated (value 1) returnA -< c distinctX :: Relation () Int32 @@ -76,15 +76,16 @@ all'X = relation $ proc () -> do assignX :: Update () assignX = updateNoPH $ proc _proj -> - assign intA0' -< value (0 :: Int32) + assign intA0' -< toFlat (value (0 :: Int32)) registerX :: Insert (String, Maybe String) registerX = insertValue $ proc () -> do - assign intC0' -< value 1 - (ph1, ()) <- placeholder -< proc ph' -> do assign strC1' -< ph' - assign intC2' -< value 2 - (ph2, ()) <- placeholder -< proc ph' -> do assign mayStrC3' -< ph' - returnA -< ph1 >< ph2 + ph <- askPlaceholders -< () + assign intC0' -< toFlat (value 1) + assign strC1' -< toFlat (ph ! fst') + assign intC2' -< toFlat (value 2) + assign mayStrC3' -< toFlat (ph ! snd') + returnA -< () eqChunkedInsert :: String -> Insert a @@ -100,6 +101,7 @@ eqChunkedInsert name ins prefix row = $ prefix : replicate (n - 1) (row ++ ",") ++ [row] in eqProp' name id sql estimate) + . fmap (first detachPlaceholderOffsets) $ chunkedInsert ins where success = QSimple.Bool Nothing True @@ -236,21 +238,21 @@ nestedPiRec :: Relation () SetA nestedPiRec = relation $ proc () -> do ar <- (query . relation $ proc () -> do a <- query setA -< () - returnA -< value "Hello" >< a) -< () + returnA -< toFlat (value "Hello") >< a) -< () returnA -< ar ! snd' nestedPiCol :: Relation () String nestedPiCol = relation $ proc () -> do ar <- (query . relation $ proc () -> do a <- query setA -< () - returnA -< a >< value "Hello") -< () + returnA -< a >< toFlat (value "Hello")) -< () returnA -< ar ! snd' nestedPi :: Relation () String nestedPi = relation $ proc () -> do ar <- (query . relation $ proc () -> do a <- query setA -< () - returnA -< (value "Hello" >< a) >< value "World") -< () + returnA -< (toFlat (value "Hello") >< a) >< toFlat (value "World")) -< () returnA -< ar ! snd' nested :: [Test] @@ -283,23 +285,23 @@ _p_nested = mapM_ print [show nestedPiRec, show nestedPiCol, show nestedPi] bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> Relation () r bin53 op = relation $ proc () -> do - returnA -< value 5 `op` value 3 + returnA -< toFlat (value 5) `op` toFlat (value 3) strIn :: Relation () (Maybe Bool) strIn = relation $ proc () -> do - returnA -< value "foo" `in'` values ["foo", "bar"] + returnA -< toFlat (value "foo") `in'` values ["foo", "bar"] boolTF :: (Record Flat (Maybe Bool) -> Record Flat (Maybe Bool) -> Record Flat r) -> Relation () r boolTF op = relation $ proc () -> do - returnA -< valueTrue `op` valueFalse + returnA -< toFlat valueTrue `op` toFlat valueFalse strConcat :: Relation () String strConcat = relation $ proc () -> do - returnA -< value "Hello, " .||. value "World!" + returnA -< toFlat (value "Hello, ") .||. toFlat (value "World!") strLike :: Relation () (Maybe Bool) strLike = relation $ proc () -> do - returnA -< value "Hoge" `like` "H%" + returnA -< toFlat (value "Hoge") `like` "H%" _p_bin53 :: (Record Flat Int32 -> Record Flat Int32 -> Record Flat r) -> IO () _p_bin53 = print . bin53 @@ -332,7 +334,7 @@ justX = relation $ proc () -> do a <- query setA -< () b <- queryMaybe setB -< () - wheres -< isJust b `or'` a ! intA0' .=. value 1 + wheres -< isJust b `or'` a ! intA0' .=. toFlat (value 1) returnA -< a >< b @@ -343,7 +345,7 @@ maybeX = relation $ proc () -> do wheres -< a ?! strA2' .=. b ! mayStrB1' - returnA -< fromMaybe (value 1) (a ?! intA0') >< b + returnA -< fromMaybe (toFlat (value 1)) (a ?! intA0') >< b maybes :: [Test] maybes = @@ -545,12 +547,12 @@ updateKeyX = primaryUpdate tableOfSetA updateX :: Update () updateX = updateNoPH $ proc proj -> do - assign strA2' -< value "X" - wheres -< proj ! strA1' .=. value "A" + assign strA2' -< toFlat (value "X") + wheres -< proj ! strA1' .=. toFlat (value "A") deleteX :: Delete () deleteX = deleteNoPH $ proc proj -> do - wheres -< proj ! strA1' .=. value "A" + wheres -< proj ! strA1' .=. toFlat (value "A") effs :: [Test] effs = diff --git a/relational-record-examples/mains/examples.hs b/relational-record-examples/mains/examples.hs index e2a274c4..5d0224df 100644 --- a/relational-record-examples/mains/examples.hs +++ b/relational-record-examples/mains/examples.hs @@ -10,6 +10,7 @@ import Database.Relational.CustomSQLite3 import Database.Relational.OverloadedInstances () +import Database.Relational.TupleInstances import GHC.Generics (Generic) import Prelude hiding (product) @@ -170,7 +171,7 @@ employee_4_1_2 :: Relation () Employee employee_4_1_2 = relation $ do e <- query employee wheres $ isNothing (#endDate e) - wheres $ #title e .=. just (value "Teller") + wheres $ #title e .=. just (toFlat $ value "Teller") `or'` #startDate e .<. unsafeSQLiteDayValue "2003-01-01" return e @@ -192,11 +193,11 @@ unsafeSQLiteDayValue = unsafeProjectSqlTerms . showLiteral -- @ -- employee_4_1_2P :: Relation Day Employee -employee_4_1_2P = relation' . placeholder $ \ph -> do +employee_4_1_2P = relation' $ \ph -> do e <- query employee wheres $ isNothing (#endDate e) - wheres $ #title e .=. just (value "Teller") - `or'` #startDate e .<. ph + wheres $ #title e .=. just (toFlat $ value "Teller") + `or'` #startDate e .<. toFlat ph return e -- | sql/4.3.2 @@ -242,11 +243,11 @@ employee_4_3_2 = relation $ do -- values in order that they appear on the generated SQL. -- employee_4_3_2P :: Relation (Day,Day) Employee2 -employee_4_3_2P = relation' . placeholder $ \ph -> do +employee_4_3_2P = relation' $ \ph -> do e <- query employee let date = #startDate e - wheres $ date .>=. (! #fst) ph - wheres $ date .<=. (! #snd) ph + wheres $ date .>=. (toFlat $ (! #fst) ph) + wheres $ date .<=. (toFlat $ (! #snd) ph) return $ Employee2 |$| #empId e |*| #fname e |*| #lname e @@ -384,11 +385,11 @@ account_9_1 = relation $ do -- @ -- account_4_3_3b :: Relation String Account -account_4_3_3b = relation' $ do +account_4_3_3b = relation' $ \ph -> do a <- query account - (phProductCd,p) <- queryList' product_4_3_3b + p <- queryList' ph product_4_3_3b wheres $ #productCd a `in'` p - return (phProductCd, a) + return a -- | -- Tuple version of Generated SQL: @@ -401,12 +402,12 @@ account_4_3_3b = relation' $ do -- @ -- account_4_3_3bT :: Relation String (Int, String, Int, Maybe Double) -account_4_3_3bT = relation' $ do +account_4_3_3bT = relation' $ \ph -> do a <- query account - (phProductCd,p) <- queryList' product_4_3_3b + p <- queryList' ph product_4_3_3b wheres $ #productCd a `in'` p let at = (,,,) |$| #accountId a |*| #productCd a |*| #custId a |*| #availBalance a - return (phProductCd, at) + return at -- | -- Adhoc record version of Generated SQL: @@ -419,20 +420,20 @@ account_4_3_3bT = relation' $ do -- @ -- account_4_3_3bR :: Relation String Account1 -account_4_3_3bR = relation' $ do +account_4_3_3bR = relation' $ \ph -> do a <- query account - (phProductCd,p) <- queryList' product_4_3_3b + p <- queryList' ph product_4_3_3b wheres $ #productCd a `in'` p let ar = Account1 |$| #accountId a |*| #productCd a |*| #custId a |*| #availBalance a - return (phProductCd, ar) + return ar product_4_3_3b :: Relation String String -product_4_3_3b = relation' . placeholder $ \ph -> do +product_4_3_3b = relation' $ \ph -> do p <- query product - wheres $ #productTypeCd p .=. ph + wheres $ #productTypeCd p .=. toFlat ph return $ #productCd p -- | sql/4.3.3c @@ -603,9 +604,9 @@ join_5_1_3 = relation $ do on $ #assignedBranchId e .=. just (#branchId b) wheres $ #startDate e .<=. unsafeSQLiteDayValue "2004-01-01" - wheres $ #title e .=. just (value "Teller") - `or'` #title e .=. just (value "Head Teller") - wheres $ #name b .=. value "Woburn Branch" + wheres $ #title e .=. just (toFlat $ value "Teller") + `or'` #title e .=. just (toFlat $ value "Head Teller") + wheres $ #name b .=. toFlat (value "Woburn Branch") return $ Account3 |$| #accountId a |*| #custId a @@ -702,13 +703,13 @@ selfJoin_5_3aT = relation $ do employee_6_4_1a :: Relation () (Maybe Int, Maybe Int) employee_6_4_1a = relation $ do e <- query employee - wheres $ #title e .=. just (value "Teller") + wheres $ #title e .=. just (toFlat $ value "Teller") return $ just (#empId e) >< #assignedBranchId e account_6_4_1a :: Relation () (Maybe Int, Maybe Int) account_6_4_1a = relation $ do a <- query account - wheres $ #productCd a .=. value "SAV" + wheres $ #productCd a .=. toFlat (value "SAV") return $ #openEmpId a >< #openBranchId a union_6_4_1a_Nest :: Relation () (Maybe Int, Maybe Int) @@ -734,11 +735,11 @@ union_6_4_1a_Nest = relation $ do union_6_4_1a_Flat :: Relation () (Maybe Int, Maybe Int) union_6_4_1a_Flat = relation (do e <- query employee - wheres $ #title e .=. just (value "Teller") + wheres $ #title e .=. just (toFlat $ value "Teller") return $ just (#empId e) >< #assignedBranchId e ) `union` relation (do a <- query account - wheres $ #productCd a .=. value "SAV" + wheres $ #productCd a .=. toFlat (value "SAV") -- asc $ #openEmpId a return $ #openEmpId a >< #openBranchId a ) @@ -798,7 +799,7 @@ customer_9_4 = relation $ do wheres $ #custId a .=. #custId c return (#accountId a) ) id' count - wheres $ just (value (2 :: Int64)) .=. ca + wheres $ toFlat (just (value (2 :: Int64))) .=. ca return (customer1 c) data Customer1 = Customer1 @@ -960,13 +961,13 @@ insertEmployee_s2 :: InsertQuery () insertEmployee_s2 = insertQuery piEmployee3 . relation $ do d <- query department b <- query branch - wheres $ #name d .=. value "Administration" - wheres $ #name b .=. value "Headquarters" - return $ Employee3 |$| value "Michael" - |*| value "Smith" + wheres $ #name d .=. toFlat (value "Administration") + wheres $ #name b .=. toFlat (value "Headquarters") + return $ Employee3 |$| toFlat (value "Michael") + |*| toFlat (value "Smith") |*| unsafeSQLiteDayValue "2001-06-22" |*| just (#deptId d) - |*| value (Just "President") + |*| toFlat (value (Just "President")) |*| just (#branchId b) -- this is equal to `defineDirectPi [1,2,3,6,7,8]' @@ -1009,17 +1010,17 @@ insertEmployee_s2U :: InsertQuery () insertEmployee_s2U = insertQuery piEmployee3 . relation $ do d <- queryScalar . unsafeUnique . relation $ do d' <- query department - wheres $ #name d' .=. value "Administration" + wheres $ #name d' .=. toFlat (value "Administration") return $ #deptId d' b <- queryScalar . unsafeUnique . relation $ do b' <- query branch - wheres $ #name b' .=. value "Headquarters" + wheres $ #name b' .=. toFlat (value "Headquarters") return $ #branchId b' - return $ Employee3 |$| value "Michael" - |*| value "Smith" + return $ Employee3 |$| toFlat (value "Michael") + |*| toFlat (value "Smith") |*| unsafeSQLiteDayValue "2001-06-22" |*| d - |*| value (Just "President") + |*| toFlat (value (Just "President")) |*| b -- place the definition of Employee4 that contains template-haskell, before @@ -1045,18 +1046,17 @@ $(makeRelationalRecord ''Employee4) -- @ -- insertEmployee_s2P :: InsertQuery Employee4 -insertEmployee_s2P = insertQuery piEmployee3 . relation' $ do +insertEmployee_s2P = insertQuery piEmployee3 . relation' $ \ph -> do d <- query department b <- query branch - wheres $ #name d .=. value "Administration" - wheres $ #name b .=. value "Headquarters" - placeholder $ \ph -> - return $ Employee3 |$| (! #e4Fname) ph - |*| #e4Lname ph - |*| #e4StartDate ph - |*| just (#deptId d) - |*| #e4Title ph - |*| just (#branchId b) + wheres $ #name d .=. toFlat (value "Administration") + wheres $ #name b .=. toFlat (value "Headquarters") + return $ Employee3 |$| toFlat ((! #e4Fname) ph) + |*| toFlat (#e4Lname ph) + |*| toFlat (#e4StartDate ph) + |*| just (#deptId d) + |*| toFlat (#e4Title ph) + |*| just (#branchId b) employee4 :: Employee4 employee4 = Employee4 @@ -1087,9 +1087,9 @@ employee4 = Employee4 -- updateEmployee_o3 :: Update () updateEmployee_o3 = updateNoPH $ \proj -> do - #lname <-# value "Bush" - #deptId <-# just (value 3) - wheres $ #empId (proj :: Record Flat Employee) .=. value 10 + #lname <-# toFlat (value "Bush") + #deptId <-# just (toFlat $ value 3) + wheres $ #empId (proj :: Record Flat Employee) .=. toFlat (value 10) -- | -- Placeholder version of Generated SQL: @@ -1111,10 +1111,11 @@ updateEmployee_o3 = updateNoPH $ \proj -> do -- updateEmployee_o3P :: Update (String, Int, Int) updateEmployee_o3P = update $ \proj -> do - (phLname,()) <- placeholder (\ph -> #lname <-# ph) - (phDeptId,()) <- placeholder (\ph -> #deptId <-# just ph) - (phEmpId,()) <- placeholder (\ph -> wheres $ #empId (proj :: Record Flat Employee) .=. ph) - return $ (,,) |$| phLname |*| phDeptId |*| phEmpId + ph <- askPlaceholders + #lname <-# toFlat (ph ! tuplePi3_0') + #deptId <-# toFlat (just (ph ! tuplePi3_1')) + wheres $ #empId (proj :: Record Flat Employee) .=. toFlat (ph ! tuplePi3_2') + return () -- | -- 9.4.2 Data Manipulation Using Correlated Subqueries @@ -1152,7 +1153,7 @@ updateAccount_9_4_2 = updateNoPH $ \proj -> do tl <- queryList $ relation $ do t <- query Transaction.transaction wheres $ #accountId t .=. #accountId proj - return (value (1 :: Int64)) + return $ toFlat (value (1 :: Int64)) Account.lastActivityDate' <-# (toDay $ flattenMaybe ts) wheres $ exists $ tl @@ -1176,8 +1177,8 @@ toDay dt = unsafeProjectSql $ "date(" ++ unsafeShowSql dt ++ ")" -- @ -- deleteAccount_o1 :: Delete () -deleteAccount_o1 = deleteNoPH $ \proj -> do - wheres $ proj ! Account.accountId' .=. value 2 +deleteAccount_o1 = deleteNoPH $ \proj -> + wheres $ proj ! Account.accountId' .=. toFlat (value 2) -- | -- Placeholder version of Generated SQL: @@ -1196,7 +1197,8 @@ deleteAccount_o1 = deleteNoPH $ \proj -> do -- deleteAccount_o1P :: Delete Int deleteAccount_o1P = delete $ \proj -> do - fmap fst $ placeholder (\ph -> wheres $ proj ! Account.accountId' .=. ph) + ph <- askPlaceholders + wheres $ proj ! Account.accountId' .=. toFlat ph -- | -- (original) Data modification using equality conditions @@ -1218,8 +1220,8 @@ deleteAccount_o1P = delete $ \proj -> do deleteAccount_o2 :: Delete () deleteAccount_o2 = deleteNoPH $ \proj' -> do let proj = proj' :: Record Flat Account - wheres $ #accountId proj .>=. value 10 - wheres $ #accountId proj .<=. value 20 + wheres $ #accountId proj .>=. toFlat (value 10) + wheres $ #accountId proj .<=. toFlat (value 20) -- | -- Placeholder version of Generated SQL: @@ -1231,10 +1233,11 @@ deleteAccount_o2 = deleteNoPH $ \proj' -> do -- deleteAccount_o2P :: Delete (Int, Int) deleteAccount_o2P = delete $ \proj' -> do + ph <- askPlaceholders let proj = proj' :: Record Flat Account - (phMin,()) <- placeholder (\ph -> wheres $ #accountId proj .>=. ph) - (phMax,()) <- placeholder (\ph -> wheres $ #accountId proj .<=. ph) - return (phMin >< phMax) + wheres $ #accountId proj .>=. toFlat (ph ! fst') + wheres $ #accountId proj .<=. toFlat (ph ! snd') + return () -- | -- 9.4.2 Data manipulation using correlated subqueries @@ -1260,7 +1263,7 @@ deleteEmployee_9_4_2 = deleteNoPH $ \proj -> do el <- queryList $ relation $ do e <- query employee wheres $ #deptId e .=. just (#deptId (proj :: Record Flat Department)) - return (value (1 :: Int64)) + return $ toFlat (value (1 :: Int64)) wheres $ not' . exists $ el -- diff --git a/relational-record-examples/mains/specializedExamples.hs b/relational-record-examples/mains/specializedExamples.hs index fbdc7b74..eaa7a8dd 100644 --- a/relational-record-examples/mains/specializedExamples.hs +++ b/relational-record-examples/mains/specializedExamples.hs @@ -175,7 +175,7 @@ employee_4_1_2 :: Relation () Employee employee_4_1_2 = relation $ do e <- query employee wheres $ isNothing (e ! Employee.endDate') - wheres $ e ! Employee.title' .=. just (value "Teller") + wheres $ e ! Employee.title' .=. just (toFlat (value "Teller")) `or'` e ! Employee.startDate' .<. unsafeSQLiteDayValue "2003-01-01" return e @@ -197,11 +197,11 @@ unsafeSQLiteDayValue = unsafeProjectSqlTerms . showLiteral -- @ -- employee_4_1_2P :: Relation Day Employee -employee_4_1_2P = relation' . placeholder $ \ph -> do +employee_4_1_2P = relation' $ \ph -> do e <- query employee wheres $ isNothing (e ! Employee.endDate') - wheres $ e ! Employee.title' .=. just (value "Teller") - `or'` e ! Employee.startDate' .<. ph + wheres $ e ! Employee.title' .=. just (toFlat (value "Teller")) + `or'` e ! Employee.startDate' .<. toFlat ph return e -- | sql/4.3.2 @@ -247,11 +247,11 @@ employee_4_3_2 = relation $ do -- values in order that they appear on the generated SQL. -- employee_4_3_2P :: Relation (Day,Day) Employee2 -employee_4_3_2P = relation' . placeholder $ \ph -> do +employee_4_3_2P = relation' $ \ph -> do e <- query employee let date = e ! Employee.startDate' - wheres $ date .>=. ph ! fst' - wheres $ date .<=. ph ! snd' + wheres $ date .>=. toFlat (ph ! fst') + wheres $ date .<=. toFlat (ph ! snd') return $ Employee2 |$| e ! Employee.empId' |*| e ! Employee.fname' |*| e ! Employee.lname' @@ -389,11 +389,11 @@ account_9_1 = relation $ do -- @ -- account_4_3_3b :: Relation String Account -account_4_3_3b = relation' $ do +account_4_3_3b = relation' $ \ph -> do a <- query account - (phProductCd,p) <- queryList' product_4_3_3b + p <- queryList' ph product_4_3_3b wheres $ a ! Account.productCd' `in'` p - return (phProductCd, a) + return a -- | -- Tuple version of Generated SQL: @@ -406,12 +406,12 @@ account_4_3_3b = relation' $ do -- @ -- account_4_3_3bT :: Relation String (Int, String, Int, Maybe Double) -account_4_3_3bT = relation' $ do +account_4_3_3bT = relation' $ \ph -> do a <- query account - (phProductCd,p) <- queryList' product_4_3_3b + p <- queryList' ph product_4_3_3b wheres $ a ! Account.productCd' `in'` p let at = (,,,) |$| a ! Account.accountId' |*| a ! Account.productCd' |*| a ! Account.custId' |*| a ! Account.availBalance' - return (phProductCd, at) + return at -- | -- Adhoc record version of Generated SQL: @@ -424,20 +424,20 @@ account_4_3_3bT = relation' $ do -- @ -- account_4_3_3bR :: Relation String Account1 -account_4_3_3bR = relation' $ do +account_4_3_3bR = relation' $ \ph -> do a <- query account - (phProductCd,p) <- queryList' product_4_3_3b + p <- queryList' ph product_4_3_3b wheres $ a ! Account.productCd' `in'` p let ar = Account1 |$| a ! Account.accountId' |*| a ! Account.productCd' |*| a ! Account.custId' |*| a ! Account.availBalance' - return (phProductCd, ar) + return ar product_4_3_3b :: Relation String String -product_4_3_3b = relation' . placeholder $ \ph -> do +product_4_3_3b = relation' $ \ph -> do p <- query product - wheres $ p ! Product.productTypeCd' .=. ph + wheres $ p ! Product.productTypeCd' .=. toFlat ph return $ p ! Product.productCd' -- | sql/4.3.3c @@ -608,9 +608,9 @@ join_5_1_3 = relation $ do on $ e ! Employee.assignedBranchId' .=. just (b ! Branch.branchId') wheres $ e ! Employee.startDate' .<=. unsafeSQLiteDayValue "2004-01-01" - wheres $ e ! Employee.title' .=. just (value "Teller") - `or'` e ! Employee.title' .=. just (value "Head Teller") - wheres $ b ! Branch.name' .=. value "Woburn Branch" + wheres $ e ! Employee.title' .=. just (toFlat (value "Teller")) + `or'` e ! Employee.title' .=. just (toFlat (value "Head Teller")) + wheres $ b ! Branch.name' .=. toFlat (value "Woburn Branch") return $ Account3 |$| a ! Account.accountId' |*| a ! Account.custId' @@ -707,13 +707,13 @@ selfJoin_5_3aT = relation $ do employee_6_4_1a :: Relation () (Maybe Int, Maybe Int) employee_6_4_1a = relation $ do e <- query employee - wheres $ e ! Employee.title' .=. just (value "Teller") + wheres $ e ! Employee.title' .=. just (toFlat (value "Teller")) return $ just (e ! Employee.empId') >< e ! Employee.assignedBranchId' account_6_4_1a :: Relation () (Maybe Int, Maybe Int) account_6_4_1a = relation $ do a <- query account - wheres $ a ! Account.productCd' .=. value "SAV" + wheres $ a ! Account.productCd' .=. toFlat (value "SAV") return $ a ! Account.openEmpId' >< a ! Account.openBranchId' union_6_4_1a_Nest :: Relation () (Maybe Int, Maybe Int) @@ -739,11 +739,11 @@ union_6_4_1a_Nest = relation $ do union_6_4_1a_Flat :: Relation () (Maybe Int, Maybe Int) union_6_4_1a_Flat = relation (do e <- query employee - wheres $ e ! Employee.title' .=. just (value "Teller") + wheres $ e ! Employee.title' .=. just (toFlat (value "Teller")) return $ just (e ! Employee.empId') >< e ! Employee.assignedBranchId' ) `union` relation (do a <- query account - wheres $ a ! Account.productCd' .=. value "SAV" + wheres $ a ! Account.productCd' .=. toFlat (value "SAV") -- asc $ a ! Account.openEmpId' return $ a ! Account.openEmpId' >< a ! Account.openBranchId' ) @@ -803,7 +803,7 @@ customer_9_4 = relation $ do wheres $ a ! Account.custId' .=. c ! Customer.custId' return (a ! Account.accountId') ) id' count - wheres $ just (value (2 :: Int64)) .=. ca + wheres $ just (toFlat $ value (2 :: Int64)) .=. ca return (customer1 c) data Customer1 = Customer1 @@ -965,13 +965,13 @@ insertEmployee_s2 :: InsertQuery () insertEmployee_s2 = insertQuery piEmployee3 . relation $ do d <- query department b <- query branch - wheres $ d ! Department.name' .=. value "Administration" - wheres $ b ! Branch.name' .=. value "Headquarters" - return $ Employee3 |$| value "Michael" - |*| value "Smith" + wheres $ d ! Department.name' .=. toFlat (value "Administration") + wheres $ b ! Branch.name' .=. toFlat (value "Headquarters") + return $ Employee3 |$| toFlat (value "Michael") + |*| toFlat (value "Smith") |*| unsafeSQLiteDayValue "2001-06-22" |*| just (d ! Department.deptId') - |*| value (Just "President") + |*| toFlat (value (Just "President")) |*| just (b ! Branch.branchId') -- this is equal to `defineDirectPi [1,2,3,6,7,8]' @@ -1014,17 +1014,17 @@ insertEmployee_s2U :: InsertQuery () insertEmployee_s2U = insertQuery piEmployee3 . relation $ do d <- queryScalar . unsafeUnique . relation $ do d' <- query department - wheres $ d' ! Department.name' .=. value "Administration" + wheres $ d' ! Department.name' .=. toFlat (value "Administration") return $ d' ! Department.deptId' b <- queryScalar . unsafeUnique . relation $ do b' <- query branch - wheres $ b' ! Branch.name' .=. value "Headquarters" + wheres $ b' ! Branch.name' .=. toFlat (value "Headquarters") return $ b' ! Branch.branchId' - return $ Employee3 |$| value "Michael" - |*| value "Smith" + return $ Employee3 |$| toFlat (value "Michael") + |*| toFlat (value "Smith") |*| unsafeSQLiteDayValue "2001-06-22" |*| d - |*| value (Just "President") + |*| toFlat (value (Just "President")) |*| b -- place the definition of Employee4 that contains template-haskell, before @@ -1050,18 +1050,17 @@ $(makeRelationalRecord ''Employee4) -- @ -- insertEmployee_s2P :: InsertQuery Employee4 -insertEmployee_s2P = insertQuery piEmployee3 . relation' $ do +insertEmployee_s2P = insertQuery piEmployee3 . relation' $ \ph -> do d <- query department b <- query branch - wheres $ d ! Department.name' .=. value "Administration" - wheres $ b ! Branch.name' .=. value "Headquarters" - placeholder $ \ph -> - return $ Employee3 |$| ph ! e4Fname' - |*| ph ! e4Lname' - |*| ph ! e4StartDate' - |*| just (d ! Department.deptId') - |*| ph ! e4Title' - |*| just (b ! Branch.branchId') + wheres $ d ! Department.name' .=. toFlat (value "Administration") + wheres $ b ! Branch.name' .=. toFlat (value "Headquarters") + return $ Employee3 |$| toFlat (ph ! e4Fname') + |*| toFlat (ph ! e4Lname') + |*| toFlat (ph ! e4StartDate') + |*| just (d ! Department.deptId') + |*| toFlat (ph ! e4Title') + |*| just (b ! Branch.branchId') employee4 :: Employee4 employee4 = Employee4 @@ -1092,9 +1091,9 @@ employee4 = Employee4 -- updateEmployee_o3 :: Update () updateEmployee_o3 = updateNoPH $ \proj -> do - Employee.lname' <-# value "Bush" - Employee.deptId' <-# just (value 3) - wheres $ proj ! Employee.empId' .=. value 10 + Employee.lname' <-# toFlat (value "Bush") + Employee.deptId' <-# just (toFlat (value 3)) + wheres $ proj ! Employee.empId' .=. toFlat (value 10) -- | -- Placeholder version of Generated SQL: @@ -1116,10 +1115,11 @@ updateEmployee_o3 = updateNoPH $ \proj -> do -- updateEmployee_o3P :: Update (String, Int, Int) updateEmployee_o3P = update $ \proj -> do - (phLname,()) <- placeholder (\ph -> Employee.lname' <-# ph) - (phDeptId,()) <- placeholder (\ph -> Employee.deptId' <-# just ph) - (phEmpId,()) <- placeholder (\ph -> wheres $ proj ! Employee.empId' .=. ph) - return $ (,,) |$| phLname |*| phDeptId |*| phEmpId + ph <- askPlaceholders + Employee.lname' <-# toFlat (ph ! tuplePi3_0') + Employee.deptId' <-# toFlat (just (ph ! tuplePi3_1')) + wheres $ proj ! Employee.empId' .=. toFlat (ph ! tuplePi3_2') + return () -- | -- 9.4.2 Data Manipulation Using Correlated Subqueries @@ -1157,7 +1157,7 @@ updateAccount_9_4_2 = updateNoPH $ \proj -> do tl <- queryList $ relation $ do t <- query Transaction.transaction wheres $ t ! Transaction.accountId' .=. proj ! Account.accountId' - return (value (1 :: Int64)) + return (toFlat (value (1 :: Int64))) Account.lastActivityDate' <-# (toDay $ flattenMaybe ts) wheres $ exists $ tl @@ -1181,8 +1181,8 @@ toDay dt = unsafeProjectSql $ "date(" ++ unsafeShowSql dt ++ ")" -- @ -- deleteAccount_o1 :: Delete () -deleteAccount_o1 = deleteNoPH $ \proj -> do - wheres $ proj ! Account.accountId' .=. value 2 +deleteAccount_o1 = deleteNoPH $ \proj -> + wheres $ proj ! Account.accountId' .=. toFlat (value 2) -- | -- Placeholder version of Generated SQL: @@ -1201,7 +1201,8 @@ deleteAccount_o1 = deleteNoPH $ \proj -> do -- deleteAccount_o1P :: Delete Int deleteAccount_o1P = delete $ \proj -> do - fmap fst $ placeholder (\ph -> wheres $ proj ! Account.accountId' .=. ph) + ph <- askPlaceholders + wheres $ proj ! Account.accountId' .=. toFlat ph -- | -- (original) Data modification using equality conditions @@ -1222,8 +1223,8 @@ deleteAccount_o1P = delete $ \proj -> do -- deleteAccount_o2 :: Delete () deleteAccount_o2 = deleteNoPH $ \proj -> do - wheres $ proj ! Account.accountId' .>=. value 10 - wheres $ proj ! Account.accountId' .<=. value 20 + wheres $ proj ! Account.accountId' .>=. toFlat (value 10) + wheres $ proj ! Account.accountId' .<=. toFlat (value 20) -- | -- Placeholder version of Generated SQL: @@ -1235,9 +1236,10 @@ deleteAccount_o2 = deleteNoPH $ \proj -> do -- deleteAccount_o2P :: Delete (Int, Int) deleteAccount_o2P = delete $ \proj -> do - (phMin,()) <- placeholder (\ph -> wheres $ proj ! Account.accountId' .>=. ph) - (phMax,()) <- placeholder (\ph -> wheres $ proj ! Account.accountId' .<=. ph) - return (phMin >< phMax) + ph <- askPlaceholders + wheres $ proj ! Account.accountId' .>=. toFlat (ph ! fst') + wheres $ proj ! Account.accountId' .<=. toFlat (ph ! snd') + return () -- | -- 9.4.2 Data manipulation using correlated subqueries @@ -1263,7 +1265,7 @@ deleteEmployee_9_4_2 = deleteNoPH $ \proj -> do el <- queryList $ relation $ do e <- query employee wheres $ e ! Employee.deptId' .=. just (proj ! Department.deptId') - return (value (1 :: Int64)) + return (toFlat (value (1 :: Int64))) wheres $ not' . exists $ el -- diff --git a/relational-record/src/Database/Relational/Documentation.hs b/relational-record/src/Database/Relational/Documentation.hs index 98448667..938664ce 100644 --- a/relational-record/src/Database/Relational/Documentation.hs +++ b/relational-record/src/Database/Relational/Documentation.hs @@ -118,10 +118,6 @@ module Database.Relational.Documentation ( negateMaybe, sumMaybe, - -- ** Placeholders - -- $placeholders - placeholder, - query', left', relation', diff --git a/relational-schemas/relational-schemas.cabal b/relational-schemas/relational-schemas.cabal index a347a73e..b75cc6ca 100644 --- a/relational-schemas/relational-schemas.cabal +++ b/relational-schemas/relational-schemas.cabal @@ -110,6 +110,7 @@ library , sql-words , relational-query >= 0.12.2 + , persistable-record >= 0.6 if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* diff --git a/relational-schemas/src/Database/Custom/IBMDB2.hs b/relational-schemas/src/Database/Custom/IBMDB2.hs index ac1963d5..2fdb18f5 100644 --- a/relational-schemas/src/Database/Custom/IBMDB2.hs +++ b/relational-schemas/src/Database/Custom/IBMDB2.hs @@ -20,6 +20,7 @@ module Database.Custom.IBMDB2 ( ) where import Language.SQL.Keyword (Keyword) +import Database.Record (PersistableWidth) import Database.Relational.Schema.IBMDB2.Config (config) import Database.Relational hiding (relationalQuery, @@ -28,47 +29,48 @@ import Database.Relational hiding delete, deleteNoPH, ) -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery = relationalQuery_ config -- | Make 'Insert' from derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r - => Register r (PlaceHolders p) +insertValue :: (PersistableWidth r, TableDerivable r, PersistableWidth p) + => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' config -- | Make 'Insert' from derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r - => Register r () + => ReadPlaceholders () (Register r) () -> Insert () -insertValueNoPH body = insertValue $ body >> return unitPH +insertValueNoPH = insertValue -- | Make 'InsertQuery' from derived table, 'Pi' and 'Relation'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' config -- | Make 'Update' from derived table and 'Assign' computation. -update :: TableDerivable r - => (Record Flat r -> Assign r (PlaceHolders p)) +update :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' config -- | Make 'Update' from derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r - => (Record Flat r -> Assign r ()) + => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () -updateNoPH body = update $ (>> return unitPH) . body +updateNoPH = update -- | Make 'Delete' from derived table and 'Restrict' computation. -delete :: TableDerivable r - => (Record Flat r -> Restrict (PlaceHolders p)) +delete :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' config -- | Make 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () -deleteNoPH body = delete $ (>> return unitPH) . body +deleteNoPH = delete diff --git a/relational-schemas/src/Database/Custom/MySQL.hs b/relational-schemas/src/Database/Custom/MySQL.hs index cb3265ee..8f9bed51 100644 --- a/relational-schemas/src/Database/Custom/MySQL.hs +++ b/relational-schemas/src/Database/Custom/MySQL.hs @@ -20,6 +20,7 @@ module Database.Custom.MySQL ( ) where import Language.SQL.Keyword (Keyword) +import Database.Record (PersistableWidth) import Database.Relational.Schema.MySQL.Config (config) import Database.Relational hiding (relationalQuery, @@ -28,47 +29,48 @@ import Database.Relational hiding delete, deleteNoPH, ) -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery = relationalQuery_ config -- | Make 'Insert' from derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r - => Register r (PlaceHolders p) +insertValue :: (PersistableWidth r, TableDerivable r, PersistableWidth p) + => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' config -- | Make 'Insert' from derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r - => Register r () + => ReadPlaceholders () (Register r) () -> Insert () -insertValueNoPH body = insertValue $ body >> return unitPH +insertValueNoPH = insertValue -- | Make 'InsertQuery' from derived table, 'Pi' and 'Relation'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' config -- | Make 'Update' from derived table and 'Assign' computation. -update :: TableDerivable r - => (Record Flat r -> Assign r (PlaceHolders p)) +update :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' config -- | Make 'Update' from derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r - => (Record Flat r -> Assign r ()) + => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () -updateNoPH body = update $ (>> return unitPH) . body +updateNoPH = update -- | Make 'Delete' from derived table and 'Restrict' computation. -delete :: TableDerivable r - => (Record Flat r -> Restrict (PlaceHolders p)) +delete :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' config -- | Make 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () -deleteNoPH body = delete $ (>> return unitPH) . body +deleteNoPH = delete diff --git a/relational-schemas/src/Database/Custom/Oracle.hs b/relational-schemas/src/Database/Custom/Oracle.hs index ae205446..46989448 100644 --- a/relational-schemas/src/Database/Custom/Oracle.hs +++ b/relational-schemas/src/Database/Custom/Oracle.hs @@ -20,6 +20,7 @@ module Database.Custom.Oracle ( ) where import Language.SQL.Keyword (Keyword) +import Database.Record (PersistableWidth) import Database.Relational.Schema.Oracle.Config (config) import Database.Relational hiding (relationalQuery, @@ -28,47 +29,48 @@ import Database.Relational hiding delete, deleteNoPH, ) -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery = relationalQuery_ config -- | Make 'Insert' from derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r - => Register r (PlaceHolders p) +insertValue :: (PersistableWidth r, TableDerivable r, PersistableWidth p) + => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' config -- | Make 'Insert' from derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r - => Register r () + => ReadPlaceholders () (Register r) () -> Insert () -insertValueNoPH body = insertValue $ body >> return unitPH +insertValueNoPH = insertValue -- | Make 'InsertQuery' from derived table, 'Pi' and 'Relation'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' config -- | Make 'Update' from derived table and 'Assign' computation. -update :: TableDerivable r - => (Record Flat r -> Assign r (PlaceHolders p)) +update :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' config -- | Make 'Update' from derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r - => (Record Flat r -> Assign r ()) + => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () -updateNoPH body = update $ (>> return unitPH) . body +updateNoPH = update -- | Make 'Delete' from derived table and 'Restrict' computation. -delete :: TableDerivable r - => (Record Flat r -> Restrict (PlaceHolders p)) +delete :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' config -- | Make 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () -deleteNoPH body = delete $ (>> return unitPH) . body +deleteNoPH = delete diff --git a/relational-schemas/src/Database/Custom/PostgreSQL.hs b/relational-schemas/src/Database/Custom/PostgreSQL.hs index fd156281..64e02b78 100644 --- a/relational-schemas/src/Database/Custom/PostgreSQL.hs +++ b/relational-schemas/src/Database/Custom/PostgreSQL.hs @@ -20,6 +20,7 @@ module Database.Custom.PostgreSQL ( ) where import Language.SQL.Keyword (Keyword) +import Database.Record (PersistableWidth) import Database.Relational.Schema.PostgreSQL.Config (config) import Database.Relational hiding (relationalQuery, @@ -28,47 +29,48 @@ import Database.Relational hiding delete, deleteNoPH, ) -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery = relationalQuery_ config -- | Make 'Insert' from derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r - => Register r (PlaceHolders p) +insertValue :: (PersistableWidth r, TableDerivable r, PersistableWidth p) + => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' config -- | Make 'Insert' from derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r - => Register r () + => ReadPlaceholders () (Register r) () -> Insert () -insertValueNoPH body = insertValue $ body >> return unitPH +insertValueNoPH = insertValue -- | Make 'InsertQuery' from derived table, 'Pi' and 'Relation'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' config -- | Make 'Update' from derived table and 'Assign' computation. -update :: TableDerivable r - => (Record Flat r -> Assign r (PlaceHolders p)) +update :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' config -- | Make 'Update' from derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r - => (Record Flat r -> Assign r ()) + => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () -updateNoPH body = update $ (>> return unitPH) . body +updateNoPH = update -- | Make 'Delete' from derived table and 'Restrict' computation. -delete :: TableDerivable r - => (Record Flat r -> Restrict (PlaceHolders p)) +delete :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' config -- | Make 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () -deleteNoPH body = delete $ (>> return unitPH) . body +deleteNoPH = delete diff --git a/relational-schemas/src/Database/Custom/SQLServer.hs b/relational-schemas/src/Database/Custom/SQLServer.hs index 0afcad64..d2e7d13a 100644 --- a/relational-schemas/src/Database/Custom/SQLServer.hs +++ b/relational-schemas/src/Database/Custom/SQLServer.hs @@ -20,6 +20,7 @@ module Database.Custom.SQLServer ( ) where import Language.SQL.Keyword (Keyword) +import Database.Record (PersistableWidth) import Database.Relational.Schema.SQLServer.Config (config) import Database.Relational hiding (relationalQuery, @@ -28,47 +29,48 @@ import Database.Relational hiding delete, deleteNoPH, ) -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery = relationalQuery_ config -- | Make 'Insert' from derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r - => Register r (PlaceHolders p) +insertValue :: (PersistableWidth r, TableDerivable r, PersistableWidth p) + => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' config -- | Make 'Insert' from derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r - => Register r () + => ReadPlaceholders () (Register r) () -> Insert () -insertValueNoPH body = insertValue $ body >> return unitPH +insertValueNoPH = insertValue -- | Make 'InsertQuery' from derived table, 'Pi' and 'Relation'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' config -- | Make 'Update' from derived table and 'Assign' computation. -update :: TableDerivable r - => (Record Flat r -> Assign r (PlaceHolders p)) +update :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' config -- | Make 'Update' from derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r - => (Record Flat r -> Assign r ()) + => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () -updateNoPH body = update $ (>> return unitPH) . body +updateNoPH = update -- | Make 'Delete' from derived table and 'Restrict' computation. -delete :: TableDerivable r - => (Record Flat r -> Restrict (PlaceHolders p)) +delete :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' config -- | Make 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () -deleteNoPH body = delete $ (>> return unitPH) . body +deleteNoPH = delete diff --git a/relational-schemas/src/Database/Custom/SQLite3.hs b/relational-schemas/src/Database/Custom/SQLite3.hs index d564075f..41e4ced7 100644 --- a/relational-schemas/src/Database/Custom/SQLite3.hs +++ b/relational-schemas/src/Database/Custom/SQLite3.hs @@ -20,6 +20,7 @@ module Database.Custom.SQLite3 ( ) where import Language.SQL.Keyword (Keyword) +import Database.Record (PersistableWidth) import Database.Relational.Schema.SQLite3.Config (config) import Database.Relational hiding (relationalQuery, @@ -28,47 +29,48 @@ import Database.Relational hiding delete, deleteNoPH, ) -- | From 'Relation' into typed 'Query' with suffix SQL words. -relationalQuery :: Relation p r -- ^ relation to finalize building +relationalQuery :: PersistableWidth p + => Relation p r -- ^ relation to finalize building -> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ... -> Query p r -- ^ finalized query relationalQuery = relationalQuery_ config -- | Make 'Insert' from derived table and monadic builded 'Register' object. -insertValue :: TableDerivable r - => Register r (PlaceHolders p) +insertValue :: (PersistableWidth r, TableDerivable r, PersistableWidth p) + => ReadPlaceholders p (Register r) () -> Insert p insertValue = insertValue' config -- | Make 'Insert' from derived table and monadic builded 'Register' object with no(unit) placeholder. insertValueNoPH :: TableDerivable r - => Register r () + => ReadPlaceholders () (Register r) () -> Insert () -insertValueNoPH body = insertValue $ body >> return unitPH +insertValueNoPH = insertValue -- | Make 'InsertQuery' from derived table, 'Pi' and 'Relation'. -insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p +insertQuery :: (PersistableWidth p, TableDerivable r) => Pi r r' -> Relation p r' -> InsertQuery p insertQuery = insertQuery' config -- | Make 'Update' from derived table and 'Assign' computation. -update :: TableDerivable r - => (Record Flat r -> Assign r (PlaceHolders p)) +update :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p (Assign r) ()) -> Update p update = update' config -- | Make 'Update' from derived table and 'Assign' computation with no(unit) placeholder. updateNoPH :: TableDerivable r - => (Record Flat r -> Assign r ()) + => (Record Flat r -> ReadPlaceholders () (Assign r) ()) -> Update () -updateNoPH body = update $ (>> return unitPH) . body +updateNoPH = update -- | Make 'Delete' from derived table and 'Restrict' computation. -delete :: TableDerivable r - => (Record Flat r -> Restrict (PlaceHolders p)) +delete :: (PersistableWidth p, TableDerivable r) + => (Record Flat r -> ReadPlaceholders p Restrict ()) -> Delete p delete = delete' config -- | Make 'Delete' from 'defaultConfig', derived table and 'Restrict' computation with no(unit) placeholder. deleteNoPH :: TableDerivable r - => (Record Flat r -> Restrict ()) + => (Record Flat r -> ReadPlaceholders () Restrict ()) -> Delete () -deleteNoPH body = delete $ (>> return unitPH) . body +deleteNoPH = delete diff --git a/relational-schemas/src/Database/Relational/Schema/IBMDB2.hs b/relational-schemas/src/Database/Relational/Schema/IBMDB2.hs index 727a3c36..9408ca21 100644 --- a/relational-schemas/src/Database/Relational/Schema/IBMDB2.hs +++ b/relational-schemas/src/Database/Relational/Schema/IBMDB2.hs @@ -30,7 +30,7 @@ import Language.Haskell.TH (TypeQ) import Database.Relational (Query, relationalQuery, Relation, query, relation', - wheres, (.=.), (!), (><), placeholder, asc, value) + wheres, (.=.), (!), asc, value, fst', snd', toFlat) import Control.Applicative ((<|>)) @@ -81,12 +81,12 @@ getType mapFromSql rec = do -- | 'Relation' to query 'Columns' from schema name and table name. columnsRelationFromTable :: Relation (String, String) Columns -columnsRelationFromTable = relation' $ do +columnsRelationFromTable = relation' $ \ph -> do c <- query columns - (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tabschema' .=. ph) - (nameP , ()) <- placeholder (\ph -> wheres $ c ! Columns.tabname' .=. ph) + wheres $ c ! Columns.tabschema' .=. toFlat (ph ! fst') + wheres $ c ! Columns.tabname' .=. toFlat (ph ! snd') asc $ c ! Columns.colno' - return (schemaP >< nameP, c) + return c -- | Phantom typed 'Query' to get 'Columns' from schema name and table name. columnsQuerySQL :: Query (String, String) Columns @@ -95,7 +95,7 @@ columnsQuerySQL = relationalQuery columnsRelationFromTable -- | 'Relation' to query primary key name from schema name and table name. primaryKeyRelation :: Relation (String, String) String -primaryKeyRelation = relation' $ do +primaryKeyRelation = relation' $ \ph -> do cons <- query tabconst key <- query keycoluse col <- query columns @@ -105,16 +105,16 @@ primaryKeyRelation = relation' $ do wheres $ key ! Keycoluse.colname' .=. col ! Columns.colname' wheres $ cons ! Tabconst.constname' .=. key ! Keycoluse.constname' - wheres $ col ! Columns.nulls' .=. value "N" - wheres $ cons ! Tabconst.type' .=. value "P" - wheres $ cons ! Tabconst.enforced' .=. value "Y" + wheres $ col ! Columns.nulls' .=. toFlat (value "N") + wheres $ cons ! Tabconst.type' .=. toFlat (value "P") + wheres $ cons ! Tabconst.enforced' .=. toFlat (value "Y") - (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tabschema' .=. ph) - (nameP , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tabname' .=. ph) + wheres $ cons ! Tabconst.tabschema' .=. toFlat (ph ! fst') + wheres $ cons ! Tabconst.tabname' .=. toFlat (ph ! snd') asc $ key ! Keycoluse.colseq' - return (schemaP >< nameP, key ! Keycoluse.colname') + return (key ! Keycoluse.colname') -- | Phantom typed 'Query' to get primary key name from schema name and table name. primaryKeyQuerySQL :: Query (String, String) String diff --git a/relational-schemas/src/Database/Relational/Schema/MySQL.hs b/relational-schemas/src/Database/Relational/Schema/MySQL.hs index d3961712..7b4f4bc9 100644 --- a/relational-schemas/src/Database/Relational/Schema/MySQL.hs +++ b/relational-schemas/src/Database/Relational/Schema/MySQL.hs @@ -27,10 +27,11 @@ import Database.Relational ( Query , wheres , (.=.) , (!) - , (><) - , placeholder , asc , value + , fst' + , snd' + , toFlat ) import Database.Relational.Schema.MySQL.Config @@ -90,17 +91,17 @@ getType mapFromSql rec = do columnsQuerySQL :: Query (String, String) Columns columnsQuerySQL = relationalQuery columnsRelationFromTable where - columnsRelationFromTable = relation' $ do + columnsRelationFromTable = relation' $ \ph -> do c <- query columns - (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tableSchema' .=. ph) - (nameP , ()) <- placeholder (\ph -> wheres $ c ! Columns.tableName' .=. ph) + wheres $ c ! Columns.tableSchema' .=. toFlat (ph ! fst') + wheres $ c ! Columns.tableName' .=. toFlat (ph ! snd') asc $ c ! Columns.ordinalPosition' - return (schemaP >< nameP, c) + return c primaryKeyQuerySQL :: Query (String, String) String primaryKeyQuerySQL = relationalQuery primaryKeyRelation where - primaryKeyRelation = relation' $ do + primaryKeyRelation = relation' $ \ph -> do cons <- query tableConstraints key <- query keyColumnUsage @@ -108,10 +109,10 @@ primaryKeyQuerySQL = relationalQuery primaryKeyRelation wheres $ cons ! Tabconst.tableName' .=. key ! Keycoluse.tableName' wheres $ cons ! Tabconst.constraintName' .=. key ! Keycoluse.constraintName' - (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableSchema' .=. ph) - (nameP , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableName' .=. ph) - wheres $ cons ! Tabconst.constraintType' .=. value "PRIMARY KEY" + wheres $ cons ! Tabconst.tableSchema' .=. toFlat (ph ! fst') + wheres $ cons ! Tabconst.tableName' .=. toFlat (ph ! snd') + wheres $ cons ! Tabconst.constraintType' .=. toFlat (value "PRIMARY KEY") asc $ key ! Keycoluse.ordinalPosition' - return (schemaP >< nameP, key ! Keycoluse.columnName') + return (key ! Keycoluse.columnName') diff --git a/relational-schemas/src/Database/Relational/Schema/Oracle.hs b/relational-schemas/src/Database/Relational/Schema/Oracle.hs index be401679..2daf6d58 100644 --- a/relational-schemas/src/Database/Relational/Schema/Oracle.hs +++ b/relational-schemas/src/Database/Relational/Schema/Oracle.hs @@ -78,14 +78,12 @@ getType mapFromSql cols = do -- | 'Relation' to query 'DbaTabColumns' from owner name and table name. columnsRelationFromTable :: Relation (String, String) DbaTabColumns -columnsRelationFromTable = relation' $ do +columnsRelationFromTable = relation' $ \ph -> do cols <- query dbaTabColumns - (owner, ()) <- placeholder $ \owner -> - wheres $ cols ! Cols.owner' .=. owner - (name, ()) <- placeholder $ \name -> - wheres $ cols ! Cols.tableName' .=. name + wheres $ cols ! Cols.owner' .=. toFlat (ph ! fst') + wheres $ cols ! Cols.tableName' .=. toFlat (ph ! snd') asc $ cols ! Cols.columnId' - return (owner >< name, cols) + return cols -- | Phantom typed 'Query' to get 'DbaTabColumns' from owner name and table name. columnsQuerySQL :: Query (String, String) DbaTabColumns @@ -93,7 +91,7 @@ columnsQuerySQL = relationalQuery columnsRelationFromTable -- | 'Relation' to query primary key name from owner name and table name. primaryKeyRelation :: Relation (String, String) (Maybe String) -primaryKeyRelation = relation' $ do +primaryKeyRelation = relation' $ \ph -> do cons <- query dbaConstraints cols <- query dbaTabColumns consCols <- query dbaConsColumns @@ -103,17 +101,15 @@ primaryKeyRelation = relation' $ do wheres $ consCols ! ConsCols.columnName' .=. just (cols ! Cols.columnName') wheres $ cons ! Cons.constraintName' .=. consCols ! ConsCols.constraintName' - wheres $ cols ! Cols.nullable' .=. just (value "N") - wheres $ cons ! Cons.constraintType' .=. just (value "P") + wheres $ cols ! Cols.nullable' .=. just (toFlat $ value "N") + wheres $ cons ! Cons.constraintType' .=. just (toFlat $ value "P") - (owner, ()) <- placeholder $ \owner -> - wheres $ cons ! Cons.owner' .=. just owner - (name, ()) <- placeholder $ \name -> - wheres $ cons ! Cons.tableName' .=. name + wheres $ cons ! Cons.owner' .=. just (toFlat (ph ! fst')) + wheres $ cons ! Cons.tableName' .=. toFlat (ph ! snd') asc $ consCols ! ConsCols.position' - return (owner >< name, consCols ! ConsCols.columnName') + return (consCols ! ConsCols.columnName') -- | Phantom typed 'Query' to get primary key name from owner name and table name. primaryKeyQuerySQL :: Query (String, String) (Maybe String) diff --git a/relational-schemas/src/Database/Relational/Schema/PostgreSQL.hs b/relational-schemas/src/Database/Relational/Schema/PostgreSQL.hs index 9b93c5e2..2dd28ce6 100644 --- a/relational-schemas/src/Database/Relational/Schema/PostgreSQL.hs +++ b/relational-schemas/src/Database/Relational/Schema/PostgreSQL.hs @@ -39,7 +39,7 @@ import Data.Time import Database.Relational (Query, relationalQuery, Relation, query, query', relation', relation, union, wheres, (.=.), (.>.), in', values, (!), fst', snd', - placeholder, asc, value, unsafeProjectSql, (><)) + asc, value, unsafeProjectSql, (><), toFlat,) import Database.Relational.Schema.PostgreSQL.Config import Database.Relational.Schema.PostgreSQL.PgNamespace (pgNamespace) @@ -118,47 +118,47 @@ getType mapFromSql column@(pgAttr, pgTyp) = do -- | 'Relation' to query PostgreSQL relation oid from schema name and table name. relOidRelation :: Relation (String, String) Int32 -relOidRelation = relation' $ do +relOidRelation = relation' $ \ph -> do nsp <- query pgNamespace cls <- query pgClass wheres $ cls ! Class.relnamespace' .=. nsp ! Namespace.oid' - (nspP, ()) <- placeholder (\ph -> wheres $ nsp ! Namespace.nspname' .=. ph) - (relP, ()) <- placeholder (\ph -> wheres $ cls ! Class.relname' .=. ph) + wheres $ nsp ! Namespace.nspname' .=. toFlat (ph ! fst') + wheres $ cls ! Class.relname' .=. toFlat (ph ! snd') - return (nspP >< relP, cls ! Class.oid') + return (cls ! Class.oid') -- | 'Relation' to query column attribute from schema name and table name. attributeRelation :: Relation (String, String) PgAttribute -attributeRelation = relation' $ do - (ph, reloid) <- query' relOidRelation - att <- query pgAttribute +attributeRelation = relation' $ \ph -> do + reloid <- query' ph relOidRelation + att <- query pgAttribute wheres $ att ! Attr.attrelid' .=. reloid - wheres $ att ! Attr.attnum' .>. value 0 + wheres $ att ! Attr.attnum' .>. toFlat (value 0) - return (ph, att) + return att -- | 'Relation' to query 'Column' from schema name and table name. columnRelation :: Relation (String, String) Column -columnRelation = relation' $ do - (ph, att) <- query' attributeRelation - typ <- query pgType +columnRelation = relation' $ \ph -> do + att <- query' ph attributeRelation + typ <- query pgType wheres $ att ! Attr.atttypid' .=. typ ! Type.oid' - wheres $ typ ! Type.typtype' .=. value 'b' -- 'b': base type only + wheres $ typ ! Type.typtype' .=. toFlat (value 'b') -- 'b': base type only - wheres $ typ ! Type.typcategory' `in'` values [ 'B' -- Boolean types - , 'D' -- Date/time types - , 'I' -- Network Address types - , 'N' -- Numeric types - , 'S' -- String types - , 'T' -- typespan types - ] + wheres $ typ ! Type.typcategory' `in'` (values [ 'B' -- Boolean types + , 'D' -- Date/time types + , 'I' -- Network Address types + , 'N' -- Numeric types + , 'S' -- String types + , 'T' -- typespan types + ]) asc $ att ! Attr.attnum' - return (ph, att >< typ) + return (att >< typ) -- | Phantom typed 'Query' to get 'Column' from schema name and table name. columnQuerySQL :: Query (String, String) Column @@ -166,14 +166,14 @@ columnQuerySQL = relationalQuery columnRelation -- | 'Relation' to query primary key length from schema name and table name. primaryKeyLengthRelation :: Relation (String, String) Int32 -primaryKeyLengthRelation = relation' $ do - (ph, reloid) <- query' relOidRelation - con <- query pgConstraint +primaryKeyLengthRelation = relation' $ \ph -> do + reloid <- query' ph relOidRelation + con <- query pgConstraint wheres $ con ! Constraint.conrelid' .=. reloid - wheres $ con ! Constraint.contype' .=. value 'p' -- 'p': primary key constraint type + wheres $ con ! Constraint.contype' .=. toFlat (value 'p') -- 'p': primary key constraint type - return (ph, unsafeProjectSql "array_length (conkey, 1)") + return (unsafeProjectSql "array_length (conkey, 1)") -- | Phantom typed 'Query' to get primary key length from schema name and table name. primaryKeyLengthQuerySQL :: Query (String, String) Int32 @@ -184,7 +184,7 @@ constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32)) constraintColRelation i = relation $ do con <- query pgConstraint - return $ con >< (unsafeProjectSql ("conkey[" ++ show i ++ "]") >< value i) + return $ con >< (unsafeProjectSql ("conkey[" ++ show i ++ "]") >< toFlat (value i)) -- | Make composite primary key relation from primary key length. constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32)) @@ -193,9 +193,9 @@ constraintColExpandRelation n = -- | 'Relation' to query primary key name from schema name and table name. primaryKeyRelation :: Int32 -> Relation (String, String) String -primaryKeyRelation n = relation' $ do - (ph, att) <- query' attributeRelation - conEx <- query (constraintColExpandRelation n) +primaryKeyRelation n = relation' $ \ph -> do + att <- query' ph attributeRelation + conEx <- query (constraintColExpandRelation n) let con = conEx ! fst' col' = conEx ! snd' @@ -204,11 +204,11 @@ primaryKeyRelation n = relation' $ do wheres $ con ! Constraint.conrelid' .=. att ! Attr.attrelid' wheres $ keyIx .=. att ! Attr.attnum' - wheres $ con ! Constraint.contype' .=. value 'p' -- 'p': primary key constraint type + wheres $ con ! Constraint.contype' .=. toFlat (value 'p') -- 'p': primary key constraint type asc $ keyN - return (ph, att ! Attr.attname') + return (att ! Attr.attname') -- | Phantom typed 'Query' to get primary key name from schema name and table name. primaryKeyQuerySQL :: Int32 -> Query (String, String) String diff --git a/relational-schemas/src/Database/Relational/Schema/SQLServer.hs b/relational-schemas/src/Database/Relational/Schema/SQLServer.hs index f860d0ef..59f735e8 100644 --- a/relational-schemas/src/Database/Relational/Schema/SQLServer.hs +++ b/relational-schemas/src/Database/Relational/Schema/SQLServer.hs @@ -19,16 +19,14 @@ import Data.Char (toLower) import Data.Int (Int8, Int16, Int32, Int64) import Data.Map (Map) import Data.Time (LocalTime, Day, TimeOfDay) -import Database.Relational (Query, Relation, PlaceHolders, Record, Flat, - (!), (.=.), (><), asc, relationalQuery, just, placeholder', +import Database.Relational (Query, Relation, Record, Flat, PureOperand, + fst', snd', (!), (.=.), (><), asc, relationalQuery, just, query, relation', unsafeShowSql, - unsafeProjectSql, wheres) + unsafeProjectSql, wheres, toFlat,) import Database.Relational.Schema.SQLServer.Config -import Database.Relational.Schema.SQLServer.Columns -import Database.Relational.Schema.SQLServer.Indexes -import Database.Relational.Schema.SQLServer.IndexColumns -import Database.Relational.Schema.SQLServer.Types +import Database.Relational.Schema.SQLServerSyscat.Columns +import Database.Relational.Schema.SQLServerSyscat.Types import Language.Haskell.TH (TypeQ) --{-# ANN module "HLint: ignore Redundant $" #-} @@ -82,29 +80,20 @@ getType mapFromSql rec@((cols,typs),typScms) = do sqlsrvTrue :: Record Flat Bool sqlsrvTrue = unsafeProjectSql "1" -sqlsrvObjectId :: Record Flat String -> Record Flat String -> Record Flat Int32 +sqlsrvObjectId :: Record PureOperand String -> Record PureOperand String -> Record PureOperand Int32 sqlsrvObjectId s t = unsafeProjectSql $ "OBJECT_ID(" ++ unsafeShowSql s ++ " + '.' + " ++ unsafeShowSql t ++ ")" -sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Record Flat Int32) -sqlsrvOidPlaceHolder = (nsParam >< relParam, oid) - where - (nsParam, (relParam, oid)) = - placeholder' (\nsPh -> - placeholder' (\relPh -> - sqlsrvObjectId nsPh relPh)) - columnTypeRelation :: Relation (String,String) ((Columns,Types),String) -columnTypeRelation = relation' $ do +columnTypeRelation = relation' $ \ph -> do cols <- query columns typs <- query types wheres $ cols ! Columns.userTypeId' .=. typs ! Types.userTypeId' - wheres $ cols ! Columns.objectId' .=. oid + wheres $ cols ! Columns.objectId' .=. toFlat (sqlsrvObjectId (ph ! fst') (ph ! snd')) asc $ cols ! Columns.columnId' - return (params, cols >< typs >< sqlsrvSchemaName (typs ! Types.schemaId' :: Record Flat Int32)) + return (cols >< typs >< sqlsrvSchemaName (typs ! Types.schemaId' :: Record Flat Int32)) where - (params, oid) = sqlsrvOidPlaceHolder sqlsrvSchemaName i = unsafeProjectSql $ "SCHEMA_NAME(" ++ unsafeShowSql i ++ ")" @@ -112,19 +101,18 @@ columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String) columnTypeQuerySQL = relationalQuery columnTypeRelation primaryKeyRelation :: Relation (String,String) (Maybe String) -primaryKeyRelation = relation' $ do - idxes <- query indexes - idxcol <- query indexColumns +primaryKeyRelation = relation' $ \ph -> do + idxes <- query Indexes.indexes + idxcol <- query IndexColumns.indexColumns cols <- query columns wheres $ idxes ! Indexes.objectId' .=. idxcol ! IndexColumns.objectId' wheres $ idxes ! Indexes.indexId' .=. idxcol ! IndexColumns.indexId' wheres $ idxcol ! IndexColumns.objectId' .=. cols ! Columns.objectId' wheres $ idxcol ! IndexColumns.columnId' .=. cols ! Columns.columnId' wheres $ idxes ! Indexes.isPrimaryKey' .=. just sqlsrvTrue - let (params, oid) = sqlsrvOidPlaceHolder - wheres $ idxes ! Indexes.objectId' .=. oid + wheres $ idxes ! Indexes.objectId' .=. toFlat (sqlsrvObjectId (ph ! fst') (ph ! snd')) asc $ idxcol ! IndexColumns.keyOrdinal' - return (params, cols ! Columns.name') + return (cols ! Columns.name') primaryKeyQuerySQL :: Query (String,String) (Maybe String) primaryKeyQuerySQL = relationalQuery primaryKeyRelation diff --git a/relational-schemas/src/Database/Relational/Schema/SQLite3.hs b/relational-schemas/src/Database/Relational/Schema/SQLite3.hs index 36d7857f..3ec9d411 100644 --- a/relational-schemas/src/Database/Relational/Schema/SQLite3.hs +++ b/relational-schemas/src/Database/Relational/Schema/SQLite3.hs @@ -19,6 +19,7 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.Map (Map) import Data.Time (Day, LocalTime) import Database.Relational (Query, unsafeTypedQuery) +import Database.Relational (Query, unsafeTypedQuery, attachEmptyPlaceholderOffsets) import Database.Relational.Schema.SQLite3.Config import Database.Relational.Schema.SQLite3.IndexInfo @@ -85,10 +86,10 @@ getType mapFromSql info = do else [t|Maybe $(typ)|] tableInfoQuerySQL :: String -> String -> Query () TableInfo -tableInfoQuerySQL db tbl = unsafeTypedQuery $ "pragma " ++ db ++ ".table_info(" ++ tbl ++ ");" +tableInfoQuerySQL db tbl = unsafeTypedQuery $ attachEmptyPlaceholderOffsets $ "pragma " ++ db ++ ".table_info(" ++ tbl ++ ");" indexListQuerySQL :: String -> String -> Query () IndexList -indexListQuerySQL db tbl = unsafeTypedQuery $ "pragma " ++ db ++ ".index_list(" ++ tbl ++ ");" +indexListQuerySQL db tbl = unsafeTypedQuery $ attachEmptyPlaceholderOffsets $ "pragma " ++ db ++ ".index_list(" ++ tbl ++ ");" indexInfoQuerySQL :: String -> String -> Query () IndexInfo -indexInfoQuerySQL db idx = unsafeTypedQuery $ "pragma " ++ db ++ ".index_info(" ++ idx ++ ");" +indexInfoQuerySQL db idx = unsafeTypedQuery $ attachEmptyPlaceholderOffsets $ "pragma " ++ db ++ ".index_info(" ++ idx ++ ");" From 7515b56d82c1ae8298970b0f0ace989d514daa6a Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 20 May 2019 11:26:12 +0900 Subject: [PATCH 2/7] Fix deprecation warnings --- relational-query-HDBC/src/Database/HDBC/Query/TH.hs | 3 +-- relational-query/src/Database/Relational/Record.hs | 2 +- .../src/Database/Relational/Schema/SQLServer.hs | 8 ++++---- .../src/Database/Relational/Schema/SQLite3.hs | 1 - 4 files changed, 6 insertions(+), 8 deletions(-) diff --git a/relational-query-HDBC/src/Database/HDBC/Query/TH.hs b/relational-query-HDBC/src/Database/HDBC/Query/TH.hs index 4264c1e5..88623b2b 100644 --- a/relational-query-HDBC/src/Database/HDBC/Query/TH.hs +++ b/relational-query-HDBC/src/Database/HDBC/Query/TH.hs @@ -42,8 +42,7 @@ import Language.SQL.Keyword (Keyword) import Database.Record (ToSql, FromSql, PersistableWidth) import Database.Record.TH (recordTemplate, defineSqlPersistableInstances) import Database.Relational - (Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning, - defaultConfig, Relation, relationalQuerySQL, QuerySuffix, detachPlaceholderOffsets, ) + (Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning, defaultConfig, Relation, ) import qualified Database.Relational.TH as Relational import Database.HDBC.Session (withConnectionIO) diff --git a/relational-query/src/Database/Relational/Record.hs b/relational-query/src/Database/Relational/Record.hs index 1cd4d8e7..3d24d2e7 100644 --- a/relational-query/src/Database/Relational/Record.hs +++ b/relational-query/src/Database/Relational/Record.hs @@ -124,7 +124,7 @@ unsafeProject w p pi' = $ columns p where phs = if Syntax.isPlaceholdersRecord p - then DList.fromList $ UnsafePi.unsafeExpandIndexes' w pi' + then DList.fromList $ UnsafePi.expandIndexes' w pi' else mempty -- | Trace projection path to get narrower 'Record'. diff --git a/relational-schemas/src/Database/Relational/Schema/SQLServer.hs b/relational-schemas/src/Database/Relational/Schema/SQLServer.hs index 59f735e8..2547d37c 100644 --- a/relational-schemas/src/Database/Relational/Schema/SQLServer.hs +++ b/relational-schemas/src/Database/Relational/Schema/SQLServer.hs @@ -8,9 +8,11 @@ module Database.Relational.Schema.SQLServer ( ) where import qualified Data.Map as Map +import Database.Relational.Schema.SQLServer.Columns (Columns, columns) import qualified Database.Relational.Schema.SQLServer.Columns as Columns import qualified Database.Relational.Schema.SQLServer.Indexes as Indexes import qualified Database.Relational.Schema.SQLServer.IndexColumns as IndexColumns +import Database.Relational.Schema.SQLServer.Types (Types, types) import qualified Database.Relational.Schema.SQLServer.Types as Types import Control.Applicative ((<|>)) @@ -25,8 +27,6 @@ import Database.Relational (Query, Relation, Record, Flat, PureOperand, unsafeProjectSql, wheres, toFlat,) import Database.Relational.Schema.SQLServer.Config -import Database.Relational.Schema.SQLServerSyscat.Columns -import Database.Relational.Schema.SQLServerSyscat.Types import Language.Haskell.TH (TypeQ) --{-# ANN module "HLint: ignore Redundant $" #-} @@ -56,13 +56,13 @@ mapFromSqlDefault = normalizeColumn :: String -> String normalizeColumn = map toLower -notNull :: ((Columns,Types),String) -> Bool +notNull :: ((Columns, Types.Types), String) -> Bool notNull ((cols,_),_) = isTrue . Columns.isNullable $ cols where isTrue (Just b) = not b isTrue _ = True -getType :: Map String TypeQ -> ((Columns,Types),String) -> Maybe (String, TypeQ) +getType :: Map String TypeQ -> ((Columns, Types.Types), String) -> Maybe (String, TypeQ) getType mapFromSql rec@((cols,typs),typScms) = do colName <- Columns.name cols typ <- Map.lookup key mapFromSql diff --git a/relational-schemas/src/Database/Relational/Schema/SQLite3.hs b/relational-schemas/src/Database/Relational/Schema/SQLite3.hs index 3ec9d411..fefab0fb 100644 --- a/relational-schemas/src/Database/Relational/Schema/SQLite3.hs +++ b/relational-schemas/src/Database/Relational/Schema/SQLite3.hs @@ -18,7 +18,6 @@ import Data.Char (toLower, toUpper) import Data.Int (Int8, Int16, Int32, Int64) import Data.Map (Map) import Data.Time (Day, LocalTime) -import Database.Relational (Query, unsafeTypedQuery) import Database.Relational (Query, unsafeTypedQuery, attachEmptyPlaceholderOffsets) import Database.Relational.Schema.SQLite3.Config From 51f467a6d3278a3fa5e31792ca0eecc9438c5c14 Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 20 May 2019 11:29:32 +0900 Subject: [PATCH 3/7] Fix compilation error in older GHCs --- .../src/Database/HDBC/Record/Statement.hs | 1 + relational-query/relational-query.cabal | 2 ++ relational-query/src/Database/Relational/Effect.hs | 3 ++- .../src/Database/Relational/Monad/Aggregate.hs | 1 + .../Database/Relational/Monad/Trans/Aggregating.hs | 1 + .../src/Database/Relational/Monad/Trans/Join.hs | 2 +- .../src/Database/Relational/Monad/Unique.hs | 1 + .../src/Database/Relational/Projectable.hs | 2 ++ relational-query/src/Database/Relational/Record.hs | 3 +++ .../src/Database/Relational/SqlSyntax/Fold.hs | 1 + .../src/Database/Relational/SqlSyntax/Placeholders.hs | 1 + .../src/Database/Relational/SqlSyntax/Query.hs | 2 ++ .../src/Database/Relational/SqlSyntax/Types.hs | 4 +++- .../src/Database/Relational/SqlSyntax/Updates.hs | 2 ++ relational-query/src/Database/Relational/Type.hs | 11 +++++++++++ 15 files changed, 34 insertions(+), 3 deletions(-) diff --git a/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs b/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs index b09beafd..a514201b 100644 --- a/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs +++ b/relational-query-HDBC/src/Database/HDBC/Record/Statement.hs @@ -31,6 +31,7 @@ module Database.HDBC.Record.Statement ( ) where import Control.Exception (bracket) +import Data.Traversable (traverse) import Database.Relational (UntypeableNoFetch (untypeNoFetch), sortByPlaceholderOffsets, diff --git a/relational-query/relational-query.cabal b/relational-query/relational-query.cabal index 2068628e..03334b17 100644 --- a/relational-query/relational-query.cabal +++ b/relational-query/relational-query.cabal @@ -119,6 +119,8 @@ library , persistable-record >= 0.6 if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* + if impl(ghc < 8) + build-depends: semigroups hs-source-dirs: src ghc-options: -Wall -fsimpl-tick-factor=200 diff --git a/relational-query/src/Database/Relational/Effect.hs b/relational-query/src/Database/Relational/Effect.hs index c70a84a4..e5c4aeea 100644 --- a/relational-query/src/Database/Relational/Effect.hs +++ b/relational-query/src/Database/Relational/Effect.hs @@ -41,10 +41,11 @@ module Database.Relational.Effect ( sqlFromUpdateTarget, ) where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Monad (void) import Data.Monoid ((<>)) import Data.List (unfoldr) +import Data.Traversable (sequenceA) import Language.SQL.Keyword (Keyword(..)) import Database.Record.Persistable (PersistableWidth) diff --git a/relational-query/src/Database/Relational/Monad/Aggregate.hs b/relational-query/src/Database/Relational/Monad/Aggregate.hs index 55c4c9ef..ca127642 100644 --- a/relational-query/src/Database/Relational/Monad/Aggregate.hs +++ b/relational-query/src/Database/Relational/Monad/Aggregate.hs @@ -26,6 +26,7 @@ module Database.Relational.Monad.Aggregate ( Window, over ) where +import Control.Applicative ((<$>), (<*>)) import Data.Functor.Identity (Identity (runIdentity)) import Data.Monoid ((<>)) diff --git a/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs b/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs index 7d137211..9337b648 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Aggregating.hs @@ -33,6 +33,7 @@ import Control.Monad.Trans.Writer (WriterT, runWriterT, tell) import Control.Applicative (Applicative, (<$>)) import Control.Arrow (second) import Data.DList (DList, fromList, toList, singleton) +import Data.Monoid (mempty) import Data.Functor.Identity (Identity (runIdentity)) diff --git a/relational-query/src/Database/Relational/Monad/Trans/Join.hs b/relational-query/src/Database/Relational/Monad/Trans/Join.hs index 44575c08..afd62a3b 100644 --- a/relational-query/src/Database/Relational/Monad/Trans/Join.hs +++ b/relational-query/src/Database/Relational/Monad/Trans/Join.hs @@ -31,7 +31,7 @@ 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 Data.Monoid (Last (Last, getLast), (<>)) import Database.Relational.Internal.ContextType (Flat, PureOperand) import Database.Relational.Internal.Config (addQueryTableAliasAS) diff --git a/relational-query/src/Database/Relational/Monad/Unique.hs b/relational-query/src/Database/Relational/Monad/Unique.hs index b9db4b32..3a20331a 100644 --- a/relational-query/src/Database/Relational/Monad/Unique.hs +++ b/relational-query/src/Database/Relational/Monad/Unique.hs @@ -20,6 +20,7 @@ module Database.Relational.Monad.Unique ) where import Control.Applicative (Applicative) +import Data.Monoid (mempty) import Database.Relational.SqlSyntax (Duplication, Record, JoinProduct, NodeAttr, diff --git a/relational-query/src/Database/Relational/Projectable.hs b/relational-query/src/Database/Relational/Projectable.hs index c66c5d8e..79362b24 100644 --- a/relational-query/src/Database/Relational/Projectable.hs +++ b/relational-query/src/Database/Relational/Projectable.hs @@ -75,9 +75,11 @@ module Database.Relational.Projectable ( import Prelude hiding (pi) +import Control.Applicative ((<$>), (<*>)) import Data.String (IsString) import Data.Functor.ProductIsomorphic ((|$|), ProductIsoApplicative, (|*|), ) +import Data.Monoid (mempty) import Language.SQL.Keyword (Keyword) import qualified Language.SQL.Keyword as SQL diff --git a/relational-query/src/Database/Relational/Record.hs b/relational-query/src/Database/Relational/Record.hs index 3d24d2e7..10d1827d 100644 --- a/relational-query/src/Database/Relational/Record.hs +++ b/relational-query/src/Database/Relational/Record.hs @@ -47,9 +47,12 @@ module Database.Relational.Record ( import Prelude hiding (pi) import qualified Data.DList as DList +import Control.Applicative ((<$>), (<*>)) +import Data.Monoid (mempty) import Data.Functor.ProductIsomorphic (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), ProductIsoEmpty, pureE, peRight, peLeft, ) +import Data.Traversable (traverse) import qualified Language.SQL.Keyword as SQL diff --git a/relational-query/src/Database/Relational/SqlSyntax/Fold.hs b/relational-query/src/Database/Relational/SqlSyntax/Fold.hs index 048b92a8..620c0eef 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Fold.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Fold.hs @@ -38,6 +38,7 @@ module Database.Relational.SqlSyntax.Fold ( ) where import Control.Applicative ((<$>), pure) +import Data.Foldable (foldMap) import Data.Monoid (mempty, (<>), mconcat) import Data.Traversable (traverse) diff --git a/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs b/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs index ea781e61..464e95d4 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Placeholders.hs @@ -26,6 +26,7 @@ module Database.Relational.SqlSyntax.Placeholders import Control.Monad.Trans.Writer (writer, execWriter, runWriter, mapWriter) import Data.Array (listArray, (!)) import Data.DList (toList) +import Data.Monoid (mempty) import Database.Relational.Internal.String (StringSQL) import Database.Relational.SqlSyntax.Types diff --git a/relational-query/src/Database/Relational/SqlSyntax/Query.hs b/relational-query/src/Database/Relational/SqlSyntax/Query.hs index 00021040..5e30ec90 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Query.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Query.hs @@ -14,6 +14,8 @@ module Database.Relational.SqlSyntax.Query ( caseSearch, case', ) where +import Data.Foldable (foldMap) +import Data.Monoid ((<>)) import Database.Relational.Internal.Config (Config) import Database.Relational.SqlSyntax.Types (Duplication (..), SetOp (..), BinOp (..), diff --git a/relational-query/src/Database/Relational/SqlSyntax/Types.hs b/relational-query/src/Database/Relational/SqlSyntax/Types.hs index 5b17a3c0..21ddb59b 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Types.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Types.hs @@ -60,12 +60,13 @@ module Database.Relational.SqlSyntax.Types ( ) where import Prelude hiding (and, product) +import Control.Applicative (Applicative, (<$>), (<*>)) import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Writer (WriterT, runWriterT, writer, tell) import Data.DList (DList) import Data.Foldable (Foldable) import Data.Functor.Identity (Identity) -import Data.Monoid (Monoid, mempty) +import Data.Monoid (Monoid, mappend, mempty) import Data.Semigroup (Semigroup, (<>)) import Data.Traversable (Traversable) @@ -234,6 +235,7 @@ instance Semigroup a => Semigroup (WithPlaceholderOffsets a) where instance Monoid a => Monoid (WithPlaceholderOffsets a) where mempty = withPlaceholderOffsets mempty mempty + mappend ma mb = mappend <$> ma <*> mb withPlaceholderOffsets :: PlaceholderOffsets -> a -> WithPlaceholderOffsets a withPlaceholderOffsets phs x = WithPlaceholderOffsetsT $ writer (x, phs) diff --git a/relational-query/src/Database/Relational/SqlSyntax/Updates.hs b/relational-query/src/Database/Relational/SqlSyntax/Updates.hs index bf76465f..ca6a3423 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Updates.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Updates.hs @@ -18,7 +18,9 @@ module Database.Relational.SqlSyntax.Updates ( composeValuesListWithColumns, ) where +import Control.Applicative ((<$>), (<*>)) import Data.Monoid ((<>)) +import Data.Traversable (traverse) import Language.SQL.Keyword (Keyword(..), (|*|), (.=.)) import qualified Language.SQL.Keyword as SQL diff --git a/relational-query/src/Database/Relational/Type.hs b/relational-query/src/Database/Relational/Type.hs index c179bdeb..58ee31d6 100644 --- a/relational-query/src/Database/Relational/Type.hs +++ b/relational-query/src/Database/Relational/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -61,7 +62,12 @@ module Database.Relational.Type ( derivedDelete', derivedDelete, ) where +import Control.Applicative ((<$>)) +#if MIN_VERSION_base(4, 7, 0) import Data.Coerce (coerce) +#else +import Unsafe.Coerce (unsafeCoerce) +#endif import Data.DList (fromList) import Data.Monoid ((<>), mconcat) @@ -263,6 +269,11 @@ updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r) -> Update r updateAllColumnNoPH = coerce . typedUpdate' defaultConfig derivedTable . liftTargetAllColumn' +#if !(MIN_VERSION_base(4, 7, 0)) + where + coerce :: a -> b + coerce = unsafeCoerce +#endif {-# DEPRECATED derivedUpdateAllColumn "use `updateAllColumn` instead of this." #-} -- | Deprecated. use 'updateAllColumn'. From d90684f1b323b50411c4ee7ba46d327c5935136d Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 20 May 2019 18:36:28 +0900 Subject: [PATCH 4/7] Fix a warning --- relational-record-examples/mains/examples.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/relational-record-examples/mains/examples.hs b/relational-record-examples/mains/examples.hs index 5d0224df..25af497d 100644 --- a/relational-record-examples/mains/examples.hs +++ b/relational-record-examples/mains/examples.hs @@ -10,7 +10,7 @@ import Database.Relational.CustomSQLite3 import Database.Relational.OverloadedInstances () -import Database.Relational.TupleInstances +import Database.Relational.TupleInstances () import GHC.Generics (Generic) import Prelude hiding (product) From 28c7afa01922c3ffd949650f77d9d6aea6e62af5 Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 20 May 2019 18:39:42 +0900 Subject: [PATCH 5/7] Export `PlaceholderOffsets` No reason to hide just a type synonym of `DList Int` --- relational-query/src/Database/Relational.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/relational-query/src/Database/Relational.hs b/relational-query/src/Database/Relational.hs index 52b2895d..fe454b94 100644 --- a/relational-query/src/Database/Relational.hs +++ b/relational-query/src/Database/Relational.hs @@ -55,7 +55,7 @@ import Database.Relational.Context import Database.Relational.Config import Database.Relational.SqlSyntax (Order (..), Nulls (..), AggregateKey, Record, Predicate, PI, - WithPlaceholderOffsets, SQLWithPlaceholderOffsets, SQLWithPlaceholderOffsets', + PlaceholderOffsets, WithPlaceholderOffsets, SQLWithPlaceholderOffsets, SQLWithPlaceholderOffsets', SubQuery, unitSQL, queryWidth, withPlaceholderOffsets, attachEmptyPlaceholderOffsets, detachPlaceholderOffsets, sortByPlaceholderOffsets, placeholderOffsets, ) import Database.Relational.Record (RecordList, list, pempty, toFlat, toAggregated) From 097ef4eedc209e016ca266dcda29f37b08eecedb Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 20 May 2019 18:40:15 +0900 Subject: [PATCH 6/7] Fix: drop `FROM` by mistake --- relational-query/src/Database/Relational/Effect.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/relational-query/src/Database/Relational/Effect.hs b/relational-query/src/Database/Relational/Effect.hs index e5c4aeea..7ec8af9c 100644 --- a/relational-query/src/Database/Relational/Effect.hs +++ b/relational-query/src/Database/Relational/Effect.hs @@ -118,7 +118,7 @@ sqlWhereFromRestriction config tbl = snd . fromRestriction config tbl -- | DELETE statement with WHERE clause 'StringSQL' string from 'Restrict' computation. deleteFromRestriction :: PersistableWidth p => Config -> Table r -> (Record Flat r -> ReadPlaceholders p Restrict ()) -> SQLWithPlaceholderOffsets' -deleteFromRestriction config tbl rs = (\t r -> DELETE <> t <> r) <$> twp <*> rwp +deleteFromRestriction config tbl rs = (\t r -> DELETE <> FROM <> t <> r) <$> twp <*> rwp where (twp, rwp) = fromRestriction config tbl rs -- | Show WHERE clause. From 1e2a7a910521a26c130819797d6214c701bfaa54 Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 20 May 2019 18:43:12 +0900 Subject: [PATCH 7/7] Fix: the Foldable instance of WithPlaceholderOffsets is unexpectedly used --- .../src/Database/Relational/SqlSyntax/Fold.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/relational-query/src/Database/Relational/SqlSyntax/Fold.hs b/relational-query/src/Database/Relational/SqlSyntax/Fold.hs index 620c0eef..f3af4cf9 100644 --- a/relational-query/src/Database/Relational/SqlSyntax/Fold.hs +++ b/relational-query/src/Database/Relational/SqlSyntax/Fold.hs @@ -137,14 +137,14 @@ selectPrefixSQL up da = SELECT <> showsDuplication da <> -- 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 (Table t) = fromTableToNormalizedSQL t + d sub@(Bin {}) = showUnitSQL sub d sub@(Flat _ _ _ _ _ ots) - | null ots = showSQL sub - | otherwise = showUnitSQL sub + | null $ detachPlaceholderOffsets ots = showSQL sub + | otherwise = showUnitSQL sub d sub@(Aggregated _ _ _ _ _ _ _ ots) - | null ots = showSQL sub - | otherwise = showUnitSQL sub + | null $ detachPlaceholderOffsets ots = showSQL sub + | otherwise = showUnitSQL sub -- | SQL string for nested-query and toplevel-SQL. toSQLs :: SubQuery