{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

-- |
-- Module      : Database.Relational.Effect
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines effect statements
-- like update and delete.
module Database.Relational.Effect (
  -- * Object to express simple restriction.
  Restriction,

  -- * Object to express update target columns and restriction.
  UpdateTarget,
  liftTargetAllColumn',

  -- * Object to express insert terget.
  InsertTarget, insertTarget', piRegister,

  -- * Generate SQL from restriction.
  deleteFromRestriction,
  updateFromUpdateTarget,
  sqlChunkFromInsertTarget,
  sqlFromInsertTarget,
  sqlChunksFromRecordList,

  -- * Deprecated
  restriction, restriction',
  updateTarget, updateTarget',
  liftTargetAllColumn,
  updateTargetAllColumn, updateTargetAllColumn',
  insertTarget,
  sqlWhereFromRestriction,
  sqlFromUpdateTarget,
  ) where

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.SqlSyntax
  (Record, composeWhere, composeSets,
   composeChunkValuesWithColumns, composeValuesListWithColumns,
   Qualified, SubQuery, corrSubQueryTerm)

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 (LiteralSQL)
import Database.Relational.Projectable
  (PlaceHolders, unitPH, pwPlaceholder, placeholder, (><), value, )
import Database.Relational.Monad.BaseType (ConfigureQuery, qualifyQuery, askConfig)
import Database.Relational.Monad.Class (MonadQualify (..))
import Database.Relational.Monad.Trans.Assigning (assignings, (<-#))
import Database.Relational.Monad.Restrict (Restrict)
import qualified Database.Relational.Monad.Restrict as Restrict
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


-- helper function for UPDATE and DELETE
withQualified :: MonadQualify ConfigureQuery m => Table r -> (Record c r -> m a) -> m StringSQL
withQualified :: Table r -> (Record c r -> m a) -> m StringSQL
withQualified Table r
tbl Record c r -> m a
q = do
  let qualTandR :: MonadQualify ConfigureQuery m => Table r -> m (Qualified SubQuery, Record c r)
      qualTandR :: Table r -> m (Qualified SubQuery, Record c r)
qualTandR Table r
tbl_ = Qualify (QueryConfig Identity) (Qualified SubQuery, Record c r)
-> m (Qualified SubQuery, Record c r)
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify (Qualify (QueryConfig Identity) (Qualified SubQuery, Record c r)
 -> m (Qualified SubQuery, Record c r))
-> Qualify (QueryConfig Identity) (Qualified SubQuery, Record c r)
-> m (Qualified SubQuery, Record c r)
forall a b. (a -> b) -> a -> b
$ do
        Qualified SubQuery
qq <- SubQuery -> ConfigureQuery (Qualified SubQuery)
forall a. a -> ConfigureQuery (Qualified a)
qualifyQuery (SubQuery -> ConfigureQuery (Qualified SubQuery))
-> SubQuery -> ConfigureQuery (Qualified SubQuery)
forall a b. (a -> b) -> a -> b
$ Table r -> SubQuery
forall r. Table r -> SubQuery
Table.toSubQuery Table r
tbl_
        (Qualified SubQuery, Record c r)
-> Qualify (QueryConfig Identity) (Qualified SubQuery, Record c r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Qualified SubQuery
qq, Qualified SubQuery -> Record c r
forall c t. Qualified SubQuery -> Record c t
Record.unsafeFromQualifiedSubQuery Qualified SubQuery
qq {- qualified record expression -})
  (Qualified SubQuery
qq, Record c r
r) <- Table r -> m (Qualified SubQuery, Record c r)
forall (m :: * -> *) r c.
MonadQualify ConfigureQuery m =>
Table r -> m (Qualified SubQuery, Record c r)
qualTandR Table r
tbl
  m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m a -> m ()) -> m a -> m ()
forall a b. (a -> b) -> a -> b
$ Record c r -> m a
q Record c r
r -- placeholder info is not used
  Bool
addAS <- Config -> Bool
addModifyTableAliasAS (Config -> Bool) -> m Config -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualify (QueryConfig Identity) Config -> m Config
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify Qualify (QueryConfig Identity) Config
askConfig
  StringSQL -> m StringSQL
forall (m :: * -> *) a. Monad m => a -> m a
return (StringSQL -> m StringSQL) -> StringSQL -> m StringSQL
forall a b. (a -> b) -> a -> b
$ Bool -> Qualified SubQuery -> StringSQL
corrSubQueryTerm Bool
addAS Qualified SubQuery
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)

-- | Deprecated.
restriction :: (Record Flat r -> Restrict ()) -> Restriction () r
restriction :: (Record Flat r -> Restrict ()) -> Restriction () r
restriction = ((Restrict ()
-> Restrictings Flat ConfigureQuery (PlaceHolders ())
-> Restrictings Flat ConfigureQuery (PlaceHolders ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PlaceHolders ()
-> Restrictings Flat ConfigureQuery (PlaceHolders ())
forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders ()
unitPH) (Restrict () -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
-> (Record Flat r -> Restrict ()) -> Restriction () r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# DEPRECATED restriction "same as ((>> return unitPH) .)" #-}

-- | Deprecated.
restriction' :: (Record Flat r -> Restrict (PlaceHolders p)) -> Restriction p r
restriction' :: (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Restrict (PlaceHolders p)
restriction' = (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Restrict (PlaceHolders p)
forall a. a -> a
id
{-# DEPRECATED restriction' "same as id" #-}

fromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> (StringSQL, StringSQL)
fromRestriction :: Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
fromRestriction Config
config Table r
tbl Record Flat r -> Restrict (PlaceHolders p)
q = (StringSQL
qt, [Predicate Flat] -> StringSQL
composeWhere [Predicate Flat]
rs)
  where (StringSQL
qt, [Predicate Flat]
rs) = Restrict StringSQL -> Config -> (StringSQL, [Predicate Flat])
forall a. Restrict a -> Config -> (a, [Predicate Flat])
Restrict.extract (Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> Restrict StringSQL
forall (m :: * -> *) r c a.
MonadQualify ConfigureQuery m =>
Table r -> (Record c r -> m a) -> m StringSQL
withQualified Table r
tbl Record Flat r -> Restrict (PlaceHolders p)
q) Config
config

-- | SQL WHERE clause 'StringSQL' string from 'Restrict' computation.
sqlWhereFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL
sqlWhereFromRestriction :: Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> StringSQL
sqlWhereFromRestriction Config
config Table r
tbl = (StringSQL, StringSQL) -> StringSQL
forall a b. (a, b) -> b
snd ((StringSQL, StringSQL) -> StringSQL)
-> ((Record Flat r -> Restrict (PlaceHolders p))
    -> (StringSQL, StringSQL))
-> (Record Flat r -> Restrict (PlaceHolders p))
-> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
forall r p.
Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
fromRestriction Config
config Table r
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
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> StringSQL
deleteFromRestriction Config
config Table r
tbl Record Flat r -> Restrict (PlaceHolders p)
r =
  StringSQL
DELETE StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> StringSQL
FROM StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> (StringSQL -> StringSQL -> StringSQL)
-> (StringSQL, StringSQL) -> StringSQL
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
(<>) (Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
forall r p.
Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
fromRestriction Config
config Table r
tbl Record Flat r -> Restrict (PlaceHolders p)
r)

-- | Show WHERE clause.
instance TableDerivable r => Show (Record Flat r -> Restrict (PlaceHolders p)) where
  show :: (Record Flat r -> Restrict (PlaceHolders p)) -> String
show = StringSQL -> String
showStringSQL (StringSQL -> String)
-> ((Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL)
-> (Record Flat r -> Restrict (PlaceHolders p))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StringSQL, StringSQL) -> StringSQL
forall a b. (a, b) -> b
snd ((StringSQL, StringSQL) -> StringSQL)
-> ((Record Flat r -> Restrict (PlaceHolders p))
    -> (StringSQL, StringSQL))
-> (Record Flat r -> Restrict (PlaceHolders p))
-> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
forall r p.
Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
fromRestriction Config
defaultConfig Table r
forall r. TableDerivable r => Table r
derivedTable


-- | UpdateTarget type with place-holder parameter 'p' and projected record type 'r'.
type UpdateTarget p r = Record Flat r -> Assign r (PlaceHolders p)

-- | Deprecated.
updateTarget :: (Record Flat r -> Assign r ())
             -> UpdateTarget () r
updateTarget :: (Record Flat r -> Assign r ()) -> UpdateTarget () r
updateTarget =  ((Assign r ()
-> Assignings r Restrict (PlaceHolders ())
-> Assignings r Restrict (PlaceHolders ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PlaceHolders () -> Assignings r Restrict (PlaceHolders ())
forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders ()
unitPH) (Assign r () -> Assignings r Restrict (PlaceHolders ()))
-> (Record Flat r -> Assign r ()) -> UpdateTarget () r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# DEPRECATED updateTarget "old-style API. Use new-style Database.Relational.updateNoPH." #-}

-- | Deprecated.
updateTarget' :: (Record Flat r -> Assign r (PlaceHolders p))
              -> UpdateTarget p r
updateTarget' :: (Record Flat r -> Assign r (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders p)
updateTarget' = (Record Flat r -> Assign r (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders p)
forall a. a -> a
id
{-# DEPRECATED updateTarget' "same as id" #-}

updateAllColumn :: PersistableWidth r
                => (Record Flat r -> Restrict (PlaceHolders p))
                -> (Record Flat r -> Assign r (PlaceHolders (r, p)))
updateAllColumn :: (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
updateAllColumn Record Flat r -> Restrict (PlaceHolders p)
rs Record Flat r
proj = do
  (PlaceHolders r
ph0, ()) <- (Record Flat r -> Assignings r Restrict ())
-> Assignings r Restrict (PlaceHolders r, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\Record Flat r
ph -> Pi r r
forall a. Pi a a
id' Pi r r -> Record Flat r -> Assignings r Restrict ()
forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# Record Flat r
ph)
  PlaceHolders p
ph1       <- Restrict (PlaceHolders p) -> Assignings r Restrict (PlaceHolders p)
forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings (Restrict (PlaceHolders p)
 -> Assignings r Restrict (PlaceHolders p))
-> Restrict (PlaceHolders p)
-> Assignings r Restrict (PlaceHolders p)
forall a b. (a -> b) -> a -> b
$ Record Flat r -> Restrict (PlaceHolders p)
rs Record Flat r
proj
  PlaceHolders (r, p) -> Assign r (PlaceHolders (r, p))
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (r, p) -> Assign r (PlaceHolders (r, p)))
-> PlaceHolders (r, p) -> Assign r (PlaceHolders (r, p))
forall a b. (a -> b) -> a -> b
$ PlaceHolders r
ph0 PlaceHolders r -> PlaceHolders p -> PlaceHolders (r, p)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders p
ph1

-- | 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 :: (Record Flat r
 -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
-> Record Flat r -> Assign r (PlaceHolders r)
liftTargetAllColumn Record Flat r -> Restrictings Flat ConfigureQuery (PlaceHolders ())
rs = \Record Flat r
proj -> (PlaceHolders (r, ()) -> PlaceHolders r)
-> Assignings r Restrict (PlaceHolders (r, ()))
-> Assign r (PlaceHolders r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PlaceHolders (r, ()) -> PlaceHolders r
forall (f :: * -> *) e a. ProductIsoEmpty f e => f (a, e) -> f a
peRight (Assignings r Restrict (PlaceHolders (r, ()))
 -> Assign r (PlaceHolders r))
-> Assignings r Restrict (PlaceHolders (r, ()))
-> Assign r (PlaceHolders r)
forall a b. (a -> b) -> a -> b
$ (Record Flat r
 -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
-> Record Flat r -> Assignings r Restrict (PlaceHolders (r, ()))
forall r p.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
updateAllColumn Record Flat r -> Restrictings Flat ConfigureQuery (PlaceHolders ())
rs Record Flat r
proj
{-# 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' :: (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
liftTargetAllColumn' Record Flat r -> Restrict (PlaceHolders p)
rs = (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
forall r p.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
updateAllColumn Record Flat r -> Restrict (PlaceHolders p)
rs

-- | Deprecated.
updateTargetAllColumn :: PersistableWidth r
                      => (Record Flat r -> Restrict ())
                      -> (Record Flat r -> Assign r (PlaceHolders r))
updateTargetAllColumn :: (Record Flat r -> Restrict ())
-> Record Flat r -> Assign r (PlaceHolders r)
updateTargetAllColumn = (Record Flat r
 -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
-> Record Flat r -> Assign r (PlaceHolders r)
forall r.
PersistableWidth r =>
(Record Flat r
 -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
-> Record Flat r -> Assign r (PlaceHolders r)
liftTargetAllColumn ((Record Flat r
  -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
 -> Record Flat r -> Assign r (PlaceHolders r))
-> ((Record Flat r -> Restrict ())
    -> Record Flat r
    -> Restrictings Flat ConfigureQuery (PlaceHolders ()))
-> (Record Flat r -> Restrict ())
-> Record Flat r
-> Assign r (PlaceHolders r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Record Flat r -> Restrict ())
-> Record Flat r
-> Restrictings Flat ConfigureQuery (PlaceHolders ())
forall r. (Record Flat r -> Restrict ()) -> Restriction () r
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' :: (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
updateTargetAllColumn' = (Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
forall r p.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
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
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
fromUpdateTarget Config
config Table r
tbl Record Flat r -> Assign r (PlaceHolders p)
q = (StringSQL
qt, [(StringSQL, StringSQL)] -> StringSQL
composeSets (Table r -> [(StringSQL, StringSQL)]
asR Table r
tbl) StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> [Predicate Flat] -> StringSQL
composeWhere [Predicate Flat]
rs)
  where ((StringSQL
qt, Table r -> [(StringSQL, StringSQL)]
asR), [Predicate Flat]
rs) = Assign r StringSQL
-> Config
-> ((StringSQL, Table r -> [(StringSQL, StringSQL)]),
    [Predicate Flat])
forall r a.
Assign r a
-> Config
-> ((a, Table r -> [(StringSQL, StringSQL)]), [Predicate Flat])
Assign.extract (Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> Assign r StringSQL
forall (m :: * -> *) r c a.
MonadQualify ConfigureQuery m =>
Table r -> (Record c r -> m a) -> m StringSQL
withQualified Table r
tbl Record Flat r -> Assign r (PlaceHolders p)
q) Config
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 :: Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> StringSQL
sqlFromUpdateTarget Config
config Table r
tbl = (StringSQL, StringSQL) -> StringSQL
forall a b. (a, b) -> b
snd ((StringSQL, StringSQL) -> StringSQL)
-> ((Record Flat r -> Assign r (PlaceHolders p))
    -> (StringSQL, StringSQL))
-> (Record Flat r -> Assign r (PlaceHolders p))
-> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
forall r p.
Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
fromUpdateTarget Config
config Table r
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
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> StringSQL
updateFromUpdateTarget Config
config Table r
tbl Record Flat r -> Assign r (PlaceHolders p)
ut =
  StringSQL
UPDATE StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> (StringSQL -> StringSQL -> StringSQL)
-> (StringSQL, StringSQL) -> StringSQL
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
(<>) (Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
forall r p.
Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
fromUpdateTarget Config
config Table r
tbl Record Flat r -> Assign r (PlaceHolders p)
ut)

-- | Show Set clause and WHERE clause.
instance TableDerivable r => Show (Record Flat r -> Assign r (PlaceHolders p)) where
  show :: (Record Flat r -> Assign r (PlaceHolders p)) -> String
show = StringSQL -> String
showStringSQL (StringSQL -> String)
-> ((Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL)
-> (Record Flat r -> Assign r (PlaceHolders p))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StringSQL, StringSQL) -> StringSQL
forall a b. (a, b) -> b
snd ((StringSQL, StringSQL) -> StringSQL)
-> ((Record Flat r -> Assign r (PlaceHolders p))
    -> (StringSQL, StringSQL))
-> (Record Flat r -> Assign r (PlaceHolders p))
-> StringSQL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
forall r p.
Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
fromUpdateTarget Config
defaultConfig Table r
forall r. TableDerivable r => Table r
derivedTable


-- | InsertTarget type with place-holder parameter 'p' and projected record type 'r'.
newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p))

-- | Finalize 'Register' monad and generate 'InsertTarget'.
insertTarget :: Register r ()
             -> InsertTarget () r
insertTarget :: Register r () -> InsertTarget () r
insertTarget =  Register r (PlaceHolders ()) -> InsertTarget () r
forall p r. Register r (PlaceHolders p) -> InsertTarget p r
InsertTarget (Register r (PlaceHolders ()) -> InsertTarget () r)
-> (Register r () -> Register r (PlaceHolders ()))
-> Register r ()
-> InsertTarget () r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Register r ()
-> Register r (PlaceHolders ()) -> Register r (PlaceHolders ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PlaceHolders () -> Register r (PlaceHolders ())
forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders ()
unitPH)
{-# 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 p r
insertTarget' :: Register r (PlaceHolders p) -> InsertTarget p r
insertTarget' = Register r (PlaceHolders p) -> InsertTarget p r
forall p r. Register r (PlaceHolders p) -> InsertTarget p r
InsertTarget

-- | parametalized 'Register' monad from 'Pi'
piRegister :: PersistableWidth r
           => Pi r r'
           -> Register r (PlaceHolders r')
piRegister :: Pi r r' -> Register r (PlaceHolders r')
piRegister Pi r r'
pi' = do
  let (PlaceHolders r'
ph', Assignings r ConfigureQuery ()
ma) = PersistableRecordWidth r'
-> (Record Flat r' -> Assignings r ConfigureQuery ())
-> (PlaceHolders r', Assignings r ConfigureQuery ())
forall c a b.
SqlContext c =>
PersistableRecordWidth a
-> (Record c a -> b) -> (PlaceHolders a, b)
pwPlaceholder (Pi r r' -> PersistableRecordWidth r'
forall r ct.
PersistableWidth r =>
Pi r ct -> PersistableRecordWidth ct
Pi.width' Pi r r'
pi') (\Record Flat r'
ph -> Pi r r'
pi' Pi r r' -> Record Flat r' -> Assignings r ConfigureQuery ()
forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# Record Flat r'
ph)
  () <- Assignings r ConfigureQuery ()
ma
  PlaceHolders r' -> Register r (PlaceHolders r')
forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders r'
ph'

sqlChunkFromInsertTarget' :: Config
                          -> Int
                          -> Table r
                          -> InsertTarget p r
                          -> StringSQL
sqlChunkFromInsertTarget' :: Config -> Int -> Table r -> InsertTarget p r -> StringSQL
sqlChunkFromInsertTarget' Config
config Int
sz Table r
tbl (InsertTarget Register r (PlaceHolders p)
q) =
    StringSQL
INSERT StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> StringSQL
INTO StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> String -> StringSQL
stringSQL (Table r -> String
forall r. Table r -> String
Table.name Table r
tbl) StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> Int -> [(StringSQL, StringSQL)] -> StringSQL
composeChunkValuesWithColumns Int
sz (Table r -> [(StringSQL, StringSQL)]
asR Table r
tbl)
  where
    (PlaceHolders p
_ph, Table r -> [(StringSQL, StringSQL)]
asR) = Register r (PlaceHolders p)
-> Config -> (PlaceHolders p, Table r -> [(StringSQL, StringSQL)])
forall r a.
Assignings r ConfigureQuery a
-> Config -> (a, Table r -> [(StringSQL, StringSQL)])
Register.extract Register r (PlaceHolders p)
q Config
config

countChunks :: Config
            -> Table r
            -> Int
countChunks :: Config -> Table r -> Int
countChunks Config
config Table r
tbl =
    (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
w
  where
    th :: Int
th = Config -> Int
chunksInsertSize Config
config
    w :: Int
w  = Table r -> Int
forall r. Table r -> Int
Table.width Table r
tbl

-- | Make 'StringSQL' string of SQL INSERT record chunk statement from 'InsertTarget'
sqlChunkFromInsertTarget :: Config
                         -> Table r
                         -> InsertTarget p r
                         -> (StringSQL, Int)
sqlChunkFromInsertTarget :: Config -> Table r -> InsertTarget p r -> (StringSQL, Int)
sqlChunkFromInsertTarget Config
config Table r
tbl InsertTarget p r
it =
    (Config -> Int -> Table r -> InsertTarget p r -> StringSQL
forall r p.
Config -> Int -> Table r -> InsertTarget p r -> StringSQL
sqlChunkFromInsertTarget' Config
config Int
n Table r
tbl InsertTarget p r
it, Int
n)
  where
    n :: Int
n = Config -> Table r -> Int
forall r. Config -> Table r -> Int
countChunks Config
config Table r
tbl

-- | Make 'StringSQL' string of SQL INSERT statement from 'InsertTarget'
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget Config
config = Config -> Int -> Table r -> InsertTarget p r -> StringSQL
forall r p.
Config -> Int -> Table r -> InsertTarget p r -> StringSQL
sqlChunkFromInsertTarget' Config
config Int
1

-- | Make 'StringSQL' strings of SQL INSERT strings from records list
sqlChunksFromRecordList :: LiteralSQL r'
                        => Config
                        -> Table r
                        -> Pi r r'
                        -> [r']
                        -> [StringSQL]
sqlChunksFromRecordList :: Config -> Table r -> Pi r r' -> [r'] -> [StringSQL]
sqlChunksFromRecordList Config
config Table r
tbl Pi r r'
pi' [r']
xs =
    [ StringSQL
INSERT StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> StringSQL
INTO StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> String -> StringSQL
stringSQL (Table r -> String
forall r. Table r -> String
Table.name Table r
tbl) StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<>
      [[(StringSQL, StringSQL)]] -> StringSQL
composeValuesListWithColumns
      [ Table r -> [(StringSQL, StringSQL)]
tf Table r
tbl
      | r'
r <- [r']
rs
      , let ((), Table r -> [(StringSQL, StringSQL)]
tf) = Assignings r ConfigureQuery ()
-> Config -> ((), Table r -> [(StringSQL, StringSQL)])
forall r a.
Assignings r ConfigureQuery a
-> Config -> (a, Table r -> [(StringSQL, StringSQL)])
Register.extract (Pi r r'
pi' Pi r r' -> Record Flat r' -> Assignings r ConfigureQuery ()
forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# r' -> Record Flat r'
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value r'
r) Config
config
      ]
    | [r']
rs <- ([r'] -> Maybe ([r'], [r'])) -> [r'] -> [[r']]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [r'] -> Maybe ([r'], [r'])
forall a. [a] -> Maybe ([a], [a])
step [r']
xs
    ]
  where
    n :: Int
n = Config -> Table r -> Int
forall r. Config -> Table r -> Int
countChunks Config
config Table r
tbl
    step :: [a] -> Maybe ([a], [a])
step [a]
ys
      | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys    =  Maybe ([a], [a])
forall a. Maybe a
Nothing
      | Bool
otherwise  =  ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just (([a], [a]) -> Maybe ([a], [a])) -> ([a], [a]) -> Maybe ([a], [a])
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
ys