relational-query 0.11.1.0 → 0.11.2.0
raw patch · 12 files changed
+325/−95 lines, 12 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Database.Relational.Arrow: delete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p
+ Database.Relational.Arrow: delete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p
+ Database.Relational.Arrow: insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p
+ Database.Relational.Arrow: insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p
+ Database.Relational.Arrow: update :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p
+ Database.Relational.Arrow: update' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p
+ Database.Relational.Config: enableWarning :: Config -> Bool
+ Database.Relational.Effect: sqlChunksFromRecordList :: ShowConstantTermsSQL r' => Config -> Table r -> Pi r r' -> [r'] -> [StringSQL]
+ Database.Relational.Sequence: updateNumber' :: (PersistableWidth s, Integral i, ShowConstantTermsSQL i) => Config -> i -> Sequence s i -> Update ()
+ Database.Relational.SqlSyntax: composeValuesListWithColumns :: [[Assignment]] -> StringSQL
+ Database.Relational.Type: delete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p
+ Database.Relational.Type: delete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p
+ Database.Relational.Type: deleteNoPH :: TableDerivable r => RestrictedStatement r () -> Delete ()
+ Database.Relational.Type: insert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'
+ Database.Relational.Type: insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p
+ Database.Relational.Type: insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p
+ Database.Relational.Type: insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p
+ Database.Relational.Type: insertValueList :: (TableDerivable r, ShowConstantTermsSQL r') => Pi r r' -> [r'] -> [Insert ()]
+ Database.Relational.Type: insertValueList' :: (TableDerivable r, ShowConstantTermsSQL r') => Config -> Pi r r' -> [r'] -> [Insert ()]
+ Database.Relational.Type: insertValueNoPH :: TableDerivable r => Register r () -> Insert ()
+ Database.Relational.Type: keyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r
+ Database.Relational.Type: update :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p
+ Database.Relational.Type: update' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p
+ Database.Relational.Type: updateAllColumn :: (PersistableWidth r, TableDerivable r) => RestrictedStatement r (PlaceHolders p) -> Update (r, p)
+ Database.Relational.Type: updateAllColumn' :: (PersistableWidth r, TableDerivable r) => Config -> RestrictedStatement r (PlaceHolders p) -> Update (r, p)
+ Database.Relational.Type: updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r) => RestrictedStatement r () -> Update r
+ Database.Relational.Type: updateNoPH :: TableDerivable r => AssignStatement r () -> Update ()
- Database.Relational.Projectable: (!??) :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -> Pi a b -> Record cont c
+ Database.Relational.Projectable: (!??) :: (PersistableWidth a, ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -> Pi a b -> Record cont c
- Database.Relational.Projectable: flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -> Pi a b -> Record cont c
+ Database.Relational.Projectable: flattenPiMaybe :: (PersistableWidth a, ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -> Pi a b -> Record cont c
- Database.Relational.Projectable: valueFalse :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)
+ Database.Relational.Projectable: valueFalse :: OperatorContext c => Record c (Maybe Bool)
- Database.Relational.Projectable: valueTrue :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)
+ Database.Relational.Projectable: valueTrue :: OperatorContext c => Record c (Maybe Bool)
Files
- ChangeLog.md +7/−0
- relational-query.cabal +3/−2
- src/Database/Relational/Arrow.hs +54/−13
- src/Database/Relational/Effect.hs +38/−6
- src/Database/Relational/Internal/Config.hs +10/−1
- src/Database/Relational/Projectable.hs +5/−5
- src/Database/Relational/Sequence.hs +15/−14
- src/Database/Relational/SqlSyntax/Updates.hs +17/−4
- src/Database/Relational/TH.hs +4/−4
- src/Database/Relational/Type.hs +154/−28
- test/sqlsEq.hs +11/−11
- test/sqlsEqArrow.hs +7/−7
ChangeLog.md view
@@ -1,5 +1,12 @@ <!-- -*- Markdown -*- --> +## 0.11.2.0++- add insertValueList API.+- (re-)add xxxNoPH effect APIs.+- prepare to rename derivedXxx to xxx.+- deprecate typed* APIs with implicit defaultConfig.+ ## 0.11.1.0 - add compatibility module Database.Relational.Query.TH for upgrading from 0.9.
relational-query.cabal view
@@ -1,5 +1,5 @@ name: relational-query-version: 0.11.1.0+version: 0.11.2.0 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can@@ -18,7 +18,8 @@ category: Database build-type: Simple cabal-version: >=1.10-tested-with: GHC == 8.2.1+tested-with: GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3+ , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4
src/Database/Relational/Arrow.hs view
@@ -3,7 +3,7 @@ -- | -- Module : Database.Relational.Arrow--- Copyright : 2015-2017 Kei Hibino+-- Copyright : 2015-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -47,9 +47,9 @@ assign, - derivedUpdate', derivedUpdate,- derivedInsertValue', derivedInsertValue,- derivedDelete', derivedDelete,+ update', update,+ insertValue', insertValue,+ delete', delete, QueryA, @@ -60,6 +60,11 @@ Orderings, Window, Assignings, AssignStatement, Register, RestrictedStatement,++ -- * Deprecated+ derivedUpdate', derivedUpdate,+ derivedInsertValue', derivedInsertValue,+ derivedDelete', derivedDelete, ) where import Control.Category (Category)@@ -76,9 +81,9 @@ relation, relation', aggregateRelation, aggregateRelation', uniqueRelation', groupBy', key, key', set, bkey, rollup, cube, groupingSets, orderBy', orderBy, asc, desc, partitionBy, over,- derivedUpdate', derivedUpdate,- derivedInsertValue', derivedInsertValue,- derivedDelete', derivedDelete,+ update', update, derivedUpdate', derivedUpdate,+ insertValue', insertValue, derivedInsertValue', derivedInsertValue,+ delete', delete, derivedDelete', derivedDelete, QuerySimple, QueryAggregate, QueryUnique, Window, Register) import qualified Database.Relational as Monadic import qualified Database.Relational.Monad.Trans.Aggregating as Monadic@@ -418,30 +423,66 @@ -- | Same as 'Monadic.derivedUpdate''. -- Make 'Update' from assigning statement arrow using configuration.+update' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p+update' config = Monadic.update' config . runQueryA++-- | Same as 'Monadic.derivedUpdate'.+-- Make 'Update' from assigning statement arrow.+update :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p+update = Monadic.update . runQueryA++-- | Same as 'Monadic.derivedInsertValue''.+-- Make 'Insert' from register arrow using configuration.+insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p+insertValue' config = Monadic.insertValue' config . ($ ()) . runQueryA++-- | Same as 'Monadic.derivedInsertValue'.+-- Make 'Insert' from register arrow.+insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p+insertValue = Monadic.insertValue . ($ ()) . runQueryA++-- | Same as 'Monadic.derivedDelete''.+-- Make 'Update' from restrict statement arrow using configuration.+delete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p+delete' config = Monadic.delete' config . runQueryA++-- | Same as 'Monadic.derivedDelete'.+-- Make 'Update' from restrict statement arrow.+delete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p+delete = Monadic.delete . runQueryA++{-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-}+-- | Same as 'Monadic.derivedUpdate''.+-- Make 'Update' from assigning statement arrow using configuration. derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p-derivedUpdate' config = Monadic.derivedUpdate' config . runQueryA+derivedUpdate' = update' +{-# DEPRECATED derivedUpdate "use `update` instead of this." #-} -- | Same as 'Monadic.derivedUpdate'. -- Make 'Update' from assigning statement arrow. derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p-derivedUpdate = Monadic.derivedUpdate . runQueryA+derivedUpdate = update +{-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-} -- | Same as 'Monadic.derivedInsertValue''. -- Make 'Insert' from register arrow using configuration. derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p-derivedInsertValue' config = Monadic.derivedInsertValue' config . ($ ()) . runQueryA+derivedInsertValue' = insertValue' +{-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-} -- | Same as 'Monadic.derivedInsertValue'. -- Make 'Insert' from register arrow. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p-derivedInsertValue = Monadic.derivedInsertValue . ($ ()) . runQueryA+derivedInsertValue = insertValue +{-# DEPRECATED derivedDelete' "use `derivedDelete'` instead of this." #-} -- | Same as 'Monadic.derivedDelete''. -- Make 'Update' from restrict statement arrow using configuration. derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p-derivedDelete' config = Monadic.derivedDelete' config . runQueryA+derivedDelete' = delete' +{-# DEPRECATED derivedDelete "use `derivedDelete` instead of this." #-} -- | Same as 'Monadic.derivedDelete'. -- Make 'Update' from restrict statement arrow. derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p-derivedDelete = Monadic.derivedDelete . runQueryA+derivedDelete = delete
src/Database/Relational/Effect.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Effect--- Copyright : 2013-2017 Kei Hibino+-- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -26,9 +26,11 @@ sqlFromUpdateTarget, sqlChunkFromInsertTarget, sqlFromInsertTarget,+ sqlChunksFromRecordList, ) where import Data.Monoid ((<>))+import Data.List (unfoldr) import Data.Functor.ProductIsomorphic (peRight) import Language.SQL.Keyword (Keyword(..))@@ -37,16 +39,17 @@ import Database.Relational.Internal.Config (Config (chunksInsertSize), defaultConfig) import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL) import Database.Relational.SqlSyntax- (composeWhere, composeSets, composeChunkValuesWithColumns)+ (composeWhere, composeSets, composeChunkValuesWithColumns, composeValuesListWithColumns) import Database.Relational.Pi (Pi, id') import qualified Database.Relational.Pi.Unsafe as Pi import Database.Relational.Table (Table, TableDerivable, derivedTable) import qualified Database.Relational.Table as Table import qualified Database.Relational.Record as Record+import Database.Relational.ProjectableClass (ShowConstantTermsSQL) import Database.Relational.Projectable (PlaceHolders, unitPlaceHolder,- pwPlaceholder, placeholder, (><), )+ pwPlaceholder, placeholder, (><), value, ) import Database.Relational.Monad.Trans.Assigning (assignings, (<-#)) import Database.Relational.Monad.Restrict (RestrictedStatement) import qualified Database.Relational.Monad.Restrict as Restrict@@ -168,6 +171,15 @@ where (_ph, asR) = Register.extract q config +countChunks :: Config+ -> Table r+ -> Int+countChunks config tbl =+ (th + w - 1) `quot` w+ where+ th = chunksInsertSize config+ w = Table.width tbl+ -- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget' sqlChunkFromInsertTarget :: Config -> Table r@@ -176,10 +188,30 @@ sqlChunkFromInsertTarget config tbl it = (sqlChunkFromInsertTarget' config n tbl it, n) where- th = chunksInsertSize config- n = (th + w - 1) `quot` w- w = Table.width tbl+ n = countChunks config tbl -- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget' sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL sqlFromInsertTarget config = sqlChunkFromInsertTarget' config 1++-- | Make 'StringSQL' strings of SQL INSERT strings from records list+sqlChunksFromRecordList :: ShowConstantTermsSQL r'+ => Config+ -> Table r+ -> Pi r r'+ -> [r']+ -> [StringSQL]+sqlChunksFromRecordList config tbl pi' xs =+ [ INSERT <> INTO <> stringSQL (Table.name tbl) <>+ composeValuesListWithColumns+ [ tf tbl+ | r <- rs+ , let ((), tf) = Register.extract (pi' <-# value r) config+ ]+ | rs <- unfoldr step xs+ ]+ where+ n = countChunks config tbl+ step ys+ | null ys = Nothing+ | otherwise = Just $ splitAt n ys
src/Database/Relational/Internal/Config.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Internal.Config--- Copyright : 2017 Kei Hibino+-- Copyright : 2017-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -20,6 +20,7 @@ chunksInsertSize, schemaNameMode, normalizedTableName,+ enableWarning, verboseAsCompilerWarning, disableOverloadedProjection, disableSpecializedProjection,@@ -74,10 +75,15 @@ data Config = Config { productUnitSupport :: !ProductUnitSupport+ -- ^ No FROM clause (corresponding the unit of JOIN) is allowed or not. , chunksInsertSize :: !Int+ -- ^ Threshold count of placeholders in the insert statement with multi-values. , schemaNameMode :: !SchemaNameMode+ -- ^ 'SchemaNameMode' configuration , normalizedTableName :: !Bool -- ^ If True, schema names become uppercase, and table names become lowercase.+ , enableWarning :: !Bool+ -- ^ If True, print warning messages in macros of relational-record. , verboseAsCompilerWarning :: !Bool -- ^ If True, more detailed logs are printed when generating record types from schema. , disableOverloadedProjection :: !Bool@@ -85,7 +91,9 @@ , disableSpecializedProjection :: !Bool -- ^ If True, 'Database.Relational.Pi.Pi' for each column is NOT generated. , identifierQuotation :: !IdentifierQuotation+ -- ^ 'IdentifierQuotation' configuration , nameConfig :: !NameConfig+ -- ^ 'NameConfig' configuration } deriving Show -- | Default configuration of 'Config'.@@ -116,6 +124,7 @@ , chunksInsertSize = 256 , schemaNameMode = SchemaQualified , normalizedTableName = True+ , enableWarning = True , verboseAsCompilerWarning = False , disableOverloadedProjection = False , disableSpecializedProjection = False
src/Database/Relational/Projectable.hs view
@@ -5,7 +5,7 @@ -- | -- Module : Database.Relational.Projectable--- Copyright : 2013-2017 Kei Hibino+-- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -128,11 +128,11 @@ value = unsafeProjectSqlTerms . showConstantTermsSQL -- | Record with polymorphic type of SQL true value.-valueTrue :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)+valueTrue :: OperatorContext c => Record c (Maybe Bool) valueTrue = just $ value True -- | Record with polymorphic type of SQL false value.-valueFalse :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)+valueFalse :: OperatorContext c => Record c (Maybe Bool) valueFalse = just $ value False -- | RecordList with polymorphic type of SQL set value from Haskell list.@@ -611,14 +611,14 @@ flatten = id -- | Get narrower record with flatten leaf phantom Maybe types along with projection path.-flattenPiMaybe :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)+flattenPiMaybe :: (PersistableWidth a, ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Record cont c -- ^ Narrower 'Record'. Flatten 'Maybe' phantom type flattenPiMaybe p = flatten . Record.piMaybe p -- | Get narrower record with flatten leaf phantom Maybe types along with projection path.-(!??) :: (PersistableWidth a, ProjectableMaybe (Record cont), ProjectableFlattenMaybe (Maybe b) c)+(!??) :: (PersistableWidth a, ProjectableFlattenMaybe (Maybe b) c) => Record cont (Maybe a) -- ^ Source 'Record'. 'Maybe' phantom type -> Pi a b -- ^ Projection path -> Record cont c -- ^ Narrower flatten and projected object.
src/Database/Relational/Sequence.hs view
@@ -27,12 +27,13 @@ Number, unsafeSpecifyNumber, extractNumber, ($$!), ($$), - updateNumber,+ updateNumber', updateNumber, ) where import Prelude hiding (seq) import Database.Record (PersistableWidth)+import Database.Relational.Internal.Config (Config, defaultConfig) import Database.Relational.Monad.Class (wheres) import Database.Relational.Monad.BaseType (Relation) import Database.Relational.Monad.Trans.Assigning ((<-#))@@ -45,7 +46,7 @@ import Database.Relational.Relation (tableOf) import qualified Database.Relational.Relation as Relation import Database.Relational.Effect (updateTarget')-import Database.Relational.Type (Update, typedUpdate)+import Database.Relational.Type (Update, typedUpdate') -- | Basic record to express sequence-table.@@ -133,21 +134,21 @@ -> r ($$) = ($$!) -{--updateNumber :: PersistableWidth p => Sequence r p -> Update (p, p)-updateNumber seqt = typedUpdate (table seqt) . updateTarget' $ \ proj -> do- (phv', ()) <- placeholder (\ph -> key seqt <-# ph)- (phx', ()) <- placeholder (\ph -> wheres $ proj ! key seqt .<=. ph)- return $ (,) |$| phv' |*| phx'- -}+-- | Update statement for sequence table+updateNumber' :: (PersistableWidth s, Integral i, ShowConstantTermsSQL i)+ => Config+ -> i -- ^ sequence number to set. expect not SQL injectable.+ -> Sequence s i -- ^ sequence table+ -> Update ()+updateNumber' config i seqt = typedUpdate' config (seqTable seqt) . updateTarget' $ \ proj -> do+ let iv = value i+ seqKey seqt <-# iv+ wheres $ proj ! seqKey seqt .<=. iv -- fool proof+ return unitPlaceHolder -- | Update statement for sequence table updateNumber :: (PersistableWidth s, Integral i, ShowConstantTermsSQL i) => i -- ^ sequence number to set. expect not SQL injectable. -> Sequence s i -- ^ sequence table -> Update ()-updateNumber i seqt = typedUpdate (seqTable seqt) . updateTarget' $ \ proj -> do- let iv = value i- seqKey seqt <-# iv- wheres $ proj ! seqKey seqt .<=. iv -- fool proof- return unitPlaceHolder+updateNumber = updateNumber' defaultConfig
src/Database/Relational/SqlSyntax/Updates.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.SqlSyntax.Updates--- Copyright : 2013-2017 Kei Hibino+-- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -13,7 +13,9 @@ AssignColumn, AssignTerm, Assignment, composeSets,- composeChunkValues, composeChunkValuesWithColumns,+ composeChunkValues,+ composeChunkValuesWithColumns,+ composeValuesListWithColumns, ) where import Data.Monoid ((<>))@@ -42,7 +44,7 @@ assigns | null assignList = error "Update assignment list is null!" | otherwise = SET <> SQL.fold (|*|) assignList --- | Compose VALUES clause from value expression list.+-- | Compose VALUES clause from a row of value expressions. composeChunkValues :: Int -- ^ record count per chunk -> [AssignTerm] -- ^ value expression list -> Keyword@@ -53,7 +55,7 @@ | otherwise = error $ "Invalid record count value: " ++ show n0 cvs = SQL.fold (|*|) . replicate n $ rowConsStringSQL vs --- | Compose VALUES clause from value expression list.+-- | Compose columns row and VALUES clause from a row of value expressions. composeChunkValuesWithColumns :: Int -- ^ record count per chunk -> [Assignment] -- ^ -> StringSQL@@ -61,3 +63,14 @@ rowConsStringSQL cs <> composeChunkValues sz vs where (cs, vs) = unzip as++-- | Compose columns row and VALUES clause from rows list of value expressions.+composeValuesListWithColumns :: [[Assignment]]+ -> StringSQL+composeValuesListWithColumns pss =+ rowConsStringSQL cs <> VALUES <> SQL.fold (|*|) (map rowConsStringSQL vss)+ where+ cs = case pss of+ [] -> error "insertValueList: no assignment chunks"+ ps:_ -> fst $ unzip ps+ vss = map (snd . unzip) pss
src/Database/Relational/TH.hs view
@@ -7,7 +7,7 @@ -- | -- Module : Database.Relational.TH--- Copyright : 2013-2017 Kei Hibino+-- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -91,7 +91,7 @@ Config (normalizedTableName, disableOverloadedProjection, disableSpecializedProjection, schemaNameMode, nameConfig, identifierQuotation), relationalQuerySQL, Query, relationalQuery, KeyUpdate,- Insert, derivedInsert, InsertQuery, derivedInsertQuery,+ Insert, insert, InsertQuery, insertQuery, HasConstraintKey(constraintKey), Primary, NotNull, primary, primaryUpdate) import Database.Relational.InternalTH.Base (defineTuplePi, defineRecordProjections)@@ -221,10 +221,10 @@ [| derivedRelation |] let insVar = varName insVar' insDs <- simpleValD insVar [t| Insert $recordType' |]- [| derivedInsert id' |]+ [| insert id' |] let insQVar = varName insQVar' insQDs <- simpleValD insQVar [t| forall p . Relation p $recordType' -> InsertQuery p |]- [| derivedInsertQuery id' |]+ [| insertQuery id' |] return $ concat [tableDs, relDs, insDs, insQDs] -- | 'Table' and 'Relation' templates.
src/Database/Relational/Type.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Database.Relational.Type--- Copyright : 2013-2017 Kei Hibino+-- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com@@ -17,29 +17,46 @@ relationalQuerySQL, -- * Typed update statement- KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, derivedKeyUpdate,- Update (..), unsafeTypedUpdate, typedUpdate', typedUpdate, derivedUpdate', derivedUpdate,- typedUpdateAllColumn, derivedUpdateAllColumn', derivedUpdateAllColumn,+ KeyUpdate (..), unsafeTypedKeyUpdate, typedKeyUpdate, typedKeyUpdateTable, keyUpdate,+ Update (..), unsafeTypedUpdate, typedUpdate', update', update, updateNoPH,+ typedUpdateAllColumn, updateAllColumn', updateAllColumn, updateAllColumnNoPH, updateSQL, -- * Typed insert statement Insert (..), untypeChunkInsert, chunkSizeOfInsert,- unsafeTypedInsert', unsafeTypedInsert, typedInsert', typedInsert, derivedInsert,- typedInsertValue', typedInsertValue, derivedInsertValue', derivedInsertValue,- InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', typedInsertQuery, derivedInsertQuery,+ unsafeTypedInsert', unsafeTypedInsert, typedInsert', insert,+ typedInsertValue', insertValue', insertValue, insertValueNoPH,+ insertValueList', insertValueList,+ InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery', insertQuery, insertQuerySQL, -- * Typed delete statement- Delete (..), unsafeTypedDelete, typedDelete', typedDelete, derivedDelete', derivedDelete,+ Delete (..), unsafeTypedDelete, typedDelete', delete', delete, deleteNoPH, deleteSQL, -- * Generalized interfaces- UntypeableNoFetch (..)+ UntypeableNoFetch (..),++ -- * Deprecated+ typedUpdate,+ typedInsert, typedInsertValue, typedInsertQuery,+ typedDelete,++ derivedKeyUpdate,+ derivedUpdate', derivedUpdate,+ derivedUpdateAllColumn', derivedUpdateAllColumn,++ derivedInsert,+ derivedInsertValue', derivedInsertValue,+ derivedInsertQuery,++ derivedDelete', derivedDelete, ) where +import Control.Applicative ((<*)) import Data.Monoid ((<>)) import Database.Record (PersistableWidth)@@ -53,11 +70,15 @@ import Database.Relational.Monad.Register (Register) import Database.Relational.Relation (tableOf) import Database.Relational.Effect- (Restriction, restriction', UpdateTarget, updateTarget', liftTargetAllColumn', InsertTarget, insertTarget',- sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister, sqlChunkFromInsertTarget, sqlFromInsertTarget)+ (Restriction, restriction, restriction', UpdateTarget, updateTarget',+ liftTargetAllColumn, liftTargetAllColumn',+ InsertTarget, insertTarget',+ sqlWhereFromRestriction, sqlFromUpdateTarget, piRegister,+ sqlChunkFromInsertTarget, sqlFromInsertTarget, sqlChunksFromRecordList) import Database.Relational.Pi (Pi) import Database.Relational.Table (Table, TableDerivable, derivedTable)-import Database.Relational.Projectable (PlaceHolders)+import Database.Relational.ProjectableClass (ShowConstantTermsSQL)+import Database.Relational.Projectable (PlaceHolders, unitPH) import Database.Relational.SimpleSql (QuerySuffix, showsQuerySuffix, insertPrefixSQL, updateOtherThanKeySQL, updatePrefixSQL, deletePrefixSQL)@@ -107,12 +128,17 @@ typedKeyUpdateTable :: TableDerivable r => Relation () r -> Pi r p -> KeyUpdate p r typedKeyUpdateTable = typedKeyUpdate . tableOf --- derivedKeyUpdate'+-- keyUpdate' -- Config parameter is not yet required for KeyUpdate. -- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'.+keyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r+keyUpdate = typedKeyUpdate derivedTable++{-# DEPRECATED derivedKeyUpdate "use keyUpdate instead of this." #-}+-- | Make typed 'KeyUpdate' from derived table and key columns selector 'Pi'. derivedKeyUpdate :: TableDerivable r => Pi r p -> KeyUpdate p r-derivedKeyUpdate = typedKeyUpdate derivedTable+derivedKeyUpdate = keyUpdate -- | Show update SQL string instance Show (KeyUpdate p a) where@@ -134,6 +160,7 @@ typedUpdate' :: Config -> Table r -> UpdateTarget p 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 'UpdateTarget'. typedUpdate :: Table r -> UpdateTarget p r -> Update p typedUpdate = typedUpdate' defaultConfig@@ -142,13 +169,27 @@ targetTable = const derivedTable -- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'-derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p-derivedUpdate' config utc = typedUpdate' config (targetTable ut) ut where+update' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p+update' config utc = typedUpdate' config (targetTable ut) ut where ut = updateTarget' utc +{-# DEPRECATED derivedUpdate' "use `update'` instead of this." #-}+-- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'+derivedUpdate' :: TableDerivable r => Config -> AssignStatement r (PlaceHolders p) -> Update p+derivedUpdate' = update'+ -- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'+update :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p+update = update' defaultConfig++-- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement' with no(unit) placeholder.+updateNoPH :: TableDerivable r => AssignStatement r () -> Update ()+updateNoPH af = update $ (return unitPH <*) . af++{-# DEPRECATED derivedUpdate "use `update` instead of this." #-}+-- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement' derivedUpdate :: TableDerivable r => AssignStatement r (PlaceHolders p) -> Update p-derivedUpdate = derivedUpdate' defaultConfig+derivedUpdate = update -- | Make typed 'Update' from 'Config', 'Table' and 'Restriction'.@@ -166,22 +207,48 @@ => Table r -> Restriction p r -> Update (r, p)-typedUpdateAllColumn tbl r = typedUpdate tbl $ liftTargetAllColumn' r+typedUpdateAllColumn = typedUpdateAllColumn' defaultConfig -- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'. -- Update target is all column.+updateAllColumn' :: (PersistableWidth r, TableDerivable r)+ => Config+ -> RestrictedStatement r (PlaceHolders p)+ -> Update (r, p)+updateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction'++{-# DEPRECATED derivedUpdateAllColumn' "use `updateAllColumn'` instead of this." #-}+-- | Make typed 'Update' from 'Config', derived table and 'AssignStatement'.+-- Update target is all column. derivedUpdateAllColumn' :: (PersistableWidth r, TableDerivable r) => Config -> RestrictedStatement r (PlaceHolders p) -> Update (r, p)-derivedUpdateAllColumn' config = typedUpdateAllColumn' config derivedTable .restriction'+derivedUpdateAllColumn' = updateAllColumn' -- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'. -- Update target is all column.+updateAllColumn :: (PersistableWidth r, TableDerivable r)+ => RestrictedStatement r (PlaceHolders p)+ -> Update (r, p)+updateAllColumn = updateAllColumn' defaultConfig++-- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'+-- without placeholder other than target table columns.+-- Update target is all column.+updateAllColumnNoPH :: (PersistableWidth r, TableDerivable r)+ => RestrictedStatement r ()+ -> Update r+updateAllColumnNoPH =+ typedUpdate' defaultConfig derivedTable . liftTargetAllColumn . restriction++{-# DEPRECATED derivedUpdateAllColumn "use `updateAllColumn` instead of this." #-}+-- | Make typed 'Update' from 'defaultConfig', derived table and 'AssignStatement'.+-- Update target is all column. derivedUpdateAllColumn :: (PersistableWidth r, TableDerivable r) => RestrictedStatement r (PlaceHolders p) -> Update (r, p)-derivedUpdateAllColumn = derivedUpdateAllColumn' defaultConfig+derivedUpdateAllColumn = updateAllColumn -- | Show update SQL string instance Show (Update p) where@@ -216,13 +283,19 @@ typedInsert' config tbl = typedInsertValue' config tbl . insertTarget' . piRegister +{-# DEPRECATED typedInsert "use `typedInsert' defaultConfig` instead of this." #-} -- | Make typed 'Insert' from 'Table' and columns selector 'Pi'. typedInsert :: PersistableWidth r => Table r -> Pi r r' -> Insert r' typedInsert = typedInsert' defaultConfig -- | Table type inferred 'Insert'.+insert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'+insert = typedInsert' defaultConfig derivedTable++{-# DEPRECATED derivedInsert "use `insert` instead of this." #-}+-- | Table type inferred 'Insert'. derivedInsert :: (PersistableWidth r, TableDerivable r) => Pi r r' -> Insert r'-derivedInsert = typedInsert derivedTable+derivedInsert = insert -- | Make typed 'Insert' from 'Config', 'Table' and monadic builded 'InsertTarget' object. typedInsertValue' :: Config -> Table r -> InsertTarget p r -> Insert p@@ -233,21 +306,53 @@ where (ci, n) = sqlChunkFromInsertTarget config tbl it +{-# DEPRECATED typedInsertValue "use `typedInsertValue' defaultConfig` instead of this." #-} -- | Make typed 'Insert' from 'Table' and monadic builded 'InsertTarget' object. typedInsertValue :: Table r -> InsertTarget p r -> Insert p typedInsertValue = typedInsertValue' defaultConfig -- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object.-derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p-derivedInsertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs+insertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p+insertValue' config rs = typedInsertValue' config (rt rs) $ insertTarget' rs where rt :: TableDerivable r => Register r (PlaceHolders p) -> Table r rt = const derivedTable +{-# DEPRECATED derivedInsertValue' "use `insertValue'` instead of this." #-}+-- | Make typed 'Insert' from 'Config', derived table and monadic builded 'Register' object.+derivedInsertValue' :: TableDerivable r => Config -> Register r (PlaceHolders p) -> Insert p+derivedInsertValue' = insertValue'+ -- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object.+insertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p+insertValue = insertValue' defaultConfig++-- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object with no(unit) placeholder.+insertValueNoPH :: TableDerivable r => Register r () -> Insert ()+insertValueNoPH = insertValue . (return unitPH <*)++{-# DEPRECATED derivedInsertValue "use `insertValue` instead of this." #-}+-- | Make typed 'Insert' from 'defaultConfig', derived table and monadic builded 'Register' object. derivedInsertValue :: TableDerivable r => Register r (PlaceHolders p) -> Insert p-derivedInsertValue = derivedInsertValue' defaultConfig+derivedInsertValue = insertValue +-- | Make typed 'Insert' list from 'Config' and records list.+insertValueList' :: (TableDerivable r, ShowConstantTermsSQL r')+ => Config+ -> Pi r r'+ -> [r']+ -> [Insert ()]+insertValueList' config pi' =+ map (unsafeTypedInsert . showStringSQL)+ . sqlChunksFromRecordList config derivedTable pi'++-- | Make typed 'Insert' list from records list.+insertValueList :: (TableDerivable r, ShowConstantTermsSQL r')+ => Pi r r'+ -> [r']+ -> [Insert ()]+insertValueList = insertValueList' defaultConfig+ -- | Show insert SQL string. instance Show (Insert a) where show = untypeInsert@@ -267,13 +372,19 @@ typedInsertQuery' :: Config -> Table r -> Pi r r' -> Relation p r' -> InsertQuery p typedInsertQuery' config tbl pi' rel = unsafeTypedInsertQuery $ insertQuerySQL config tbl pi' rel +{-# DEPRECATED typedInsertQuery "use `typedInsertQuery' defaultConfig` instead of this." #-} -- | Make typed 'InsertQuery' from columns selector 'Table', 'Pi' and 'Relation'. typedInsertQuery :: Table r -> Pi r r' -> Relation p r' -> InsertQuery p typedInsertQuery = typedInsertQuery' defaultConfig -- | Table type inferred 'InsertQuery'.+insertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p+insertQuery = typedInsertQuery' defaultConfig derivedTable++{-# DEPRECATED derivedInsertQuery "use `insertQuery` instead of this." #-}+-- | Table type inferred 'InsertQuery'. derivedInsertQuery :: TableDerivable r => Pi r r' -> Relation p r' -> InsertQuery p-derivedInsertQuery = typedInsertQuery derivedTable+derivedInsertQuery = insertQuery -- | Show insert SQL string. instance Show (InsertQuery p) where@@ -295,6 +406,7 @@ typedDelete' :: Config -> Table r -> Restriction p r -> 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 'Restriction'. typedDelete :: Table r -> Restriction p r -> Delete p typedDelete = typedDelete' defaultConfig@@ -303,13 +415,27 @@ restrictedTable = const derivedTable -- | Make typed 'Delete' from 'Config', derived table and 'RestrictContext'-derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p-derivedDelete' config rc = typedDelete' config (restrictedTable rs) rs where+delete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p+delete' config rc = typedDelete' config (restrictedTable rs) rs where rs = restriction' rc +{-# DEPRECATED derivedDelete' "use `delete'` instead of this." #-}+-- | Make typed 'Delete' from 'Config', derived table and 'RestrictContext'+derivedDelete' :: TableDerivable r => Config -> RestrictedStatement r (PlaceHolders p) -> Delete p+derivedDelete' = delete'+ -- | Make typed 'Delete' from 'defaultConfig', derived table and 'RestrictContext'+delete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p+delete = delete' defaultConfig++-- | Make typed 'Delete' from 'defaultConfig', derived table and 'RestrictContext' with no(unit) placeholder.+deleteNoPH :: TableDerivable r => RestrictedStatement r () -> Delete ()+deleteNoPH rf = delete $ (return unitPH <*) . rf++{-# DEPRECATED derivedDelete "use `delete` instead of this." #-}+-- | Make typed 'Delete' from 'defaultConfig', derived table and 'RestrictContext' derivedDelete :: TableDerivable r => RestrictedStatement r (PlaceHolders p) -> Delete p-derivedDelete = derivedDelete' defaultConfig+derivedDelete = delete -- | Show delete SQL string instance Show (Delete p) where
test/sqlsEq.hs view
@@ -75,12 +75,12 @@ return $ a ! intA0' assignX :: Update ()-assignX = derivedUpdate $ \_proj -> do+assignX = update $ \_proj -> do intA0' <-# value (0 :: Int32) return unitPlaceHolder registerX :: Insert (String, Maybe String)-registerX = derivedInsertValue $ do+registerX = insertValue $ do intC0' <-# value 1 (ph1, ()) <- placeholder (\ph' -> strC1' <-# ph') intC2' <-# value 2@@ -622,25 +622,25 @@ ] insertX :: Insert SetA-insertX = derivedInsert id'+insertX = insert id' insertI :: Insert SetI-insertI = derivedInsert id'+insertI = insert id' insertQueryX :: InsertQuery ()-insertQueryX = derivedInsertQuery setAFromB setA+insertQueryX = insertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update ()-updateX = derivedUpdate $ \proj -> do+updateX = update $ \proj -> do strA2' <-# value "X" wheres $ proj ! strA1' .=. value "A" return unitPlaceHolder deleteX :: Delete ()-deleteX = derivedDelete $ \proj -> do+deleteX = delete $ \proj -> do wheres $ proj ! strA1' .=. value "A" return unitPlaceHolder @@ -665,7 +665,7 @@ ] updateExistsX :: Update ()-updateExistsX = derivedUpdate $ \proj -> do+updateExistsX = update $ \proj -> do strA2' <-# value "X" wheres . exists =<< (queryList . relation $ do@@ -675,7 +675,7 @@ return unitPlaceHolder updateScalarX :: Update ()-updateScalarX = derivedUpdate $ \proj -> do+updateScalarX = update $ \proj -> do strA2' <-# value "X" sb <- queryScalar . unsafeUnique . relation $ do b <- query setB@@ -685,7 +685,7 @@ return unitPlaceHolder deleteExistsX :: Delete ()-deleteExistsX = derivedDelete $ \proj -> do+deleteExistsX = delete $ \proj -> do wheres . exists =<< (queryList . relation $ do b <- query setB@@ -694,7 +694,7 @@ return unitPlaceHolder deleteScalarX :: Delete ()-deleteScalarX = derivedDelete $ \proj -> do+deleteScalarX = delete $ \proj -> do sb <- queryScalar . unsafeUnique . relation $ do b <- query setB wheres $ b ! intB0' .=. value 0
test/sqlsEqArrow.hs view
@@ -75,12 +75,12 @@ returnA -< a ! intA0' assignX :: Update ()-assignX = derivedUpdate $ proc _proj -> do+assignX = update $ proc _proj -> do assign intA0' -< value (0 :: Int32) returnA -< unitPlaceHolder registerX :: Insert (String, Maybe String)-registerX = derivedInsertValue $ proc () -> do+registerX = insertValue $ proc () -> do assign intC0' -< value 1 (ph1, ()) <- placeholder -< proc ph' -> do assign strC1' -< ph' assign intC2' -< value 2@@ -533,25 +533,25 @@ ] insertX :: Insert SetA-insertX = derivedInsert id'+insertX = insert id' insertI :: Insert SetI-insertI = derivedInsert id'+insertI = insert id' insertQueryX :: InsertQuery ()-insertQueryX = derivedInsertQuery setAFromB setA+insertQueryX = insertQuery setAFromB setA updateKeyX :: KeyUpdate Int32 SetA updateKeyX = primaryUpdate tableOfSetA updateX :: Update ()-updateX = derivedUpdate $ proc proj -> do+updateX = update $ proc proj -> do assign strA2' -< value "X" wheres -< proj ! strA1' .=. value "A" returnA -< unitPlaceHolder deleteX :: Delete ()-deleteX = derivedDelete $ proc proj -> do+deleteX = delete $ proc proj -> do wheres -< proj ! strA1' .=. value "A" returnA -< unitPlaceHolder