packages feed

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 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