{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Relational.Effect (
Restriction,
UpdateTarget,
liftTargetAllColumn',
InsertTarget, insertTarget', piRegister,
deleteFromRestriction,
updateFromUpdateTarget,
sqlChunkFromInsertTarget,
sqlFromInsertTarget,
sqlChunksFromRecordList,
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
withQualified :: MonadQualify ConfigureQuery m => Table r -> (Record c r -> m a) -> m StringSQL
withQualified :: forall (m :: * -> *) r c a.
MonadQualify ConfigureQuery m =>
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 :: forall (m :: * -> *) r c.
MonadQualify ConfigureQuery m =>
Table r -> m (Qualified SubQuery, Record c r)
qualTandR Table r
tbl_ = forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify forall a b. (a -> b) -> a -> b
$ do
Qualified SubQuery
qq <- forall a. a -> ConfigureQuery (Qualified a)
qualifyQuery forall a b. (a -> b) -> a -> b
$ forall r. Table r -> SubQuery
Table.toSubQuery Table r
tbl_
forall (m :: * -> *) a. Monad m => a -> m a
return (Qualified SubQuery
qq, forall c t. Qualified SubQuery -> Record c t
Record.unsafeFromQualifiedSubQuery Qualified SubQuery
qq )
(Qualified SubQuery
qq, Record c r
r) <- forall (m :: * -> *) r c.
MonadQualify ConfigureQuery m =>
Table r -> m (Qualified SubQuery, Record c r)
qualTandR Table r
tbl
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Record c r -> m a
q Record c r
r
Bool
addAS <- Config -> Bool
addModifyTableAliasAS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify ConfigureQuery Config
askConfig
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Qualified SubQuery -> StringSQL
corrSubQueryTerm Bool
addAS Qualified SubQuery
qq
type Restriction p r = Record Flat r -> Restrict (PlaceHolders p)
restriction :: (Record Flat r -> Restrict ()) -> Restriction () r
restriction :: forall r. (Record Flat r -> Restrict ()) -> Restriction () r
restriction = ((forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders ()
unitPH) forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# DEPRECATED restriction "same as ((>> return unitPH) .)" #-}
restriction' :: (Record Flat r -> Restrict (PlaceHolders p)) -> Restriction p r
restriction' :: forall r p.
(Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Restrict (PlaceHolders p)
restriction' = forall a. a -> a
id
{-# DEPRECATED restriction' "same as id" #-}
fromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> (StringSQL, StringSQL)
fromRestriction :: 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)
q = (StringSQL
qt, [Predicate Flat] -> StringSQL
composeWhere [Predicate Flat]
rs)
where (StringSQL
qt, [Predicate Flat]
rs) = forall a. Restrict a -> Config -> (a, [Predicate Flat])
Restrict.extract (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
sqlWhereFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL
sqlWhereFromRestriction :: forall r p.
Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> StringSQL
sqlWhereFromRestriction Config
config Table r
tbl = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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." #-}
deleteFromRestriction :: Config -> Table r -> (Record Flat r -> Restrict (PlaceHolders p)) -> StringSQL
deleteFromRestriction :: forall r p.
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 forall a. Semigroup a => a -> a -> a
<> StringSQL
FROM forall a. Semigroup a => a -> a -> a
<> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Semigroup a => a -> a -> a
(<>) (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)
instance TableDerivable r => Show (Record Flat r -> Restrict (PlaceHolders p)) where
show :: (Record Flat r -> Restrict (PlaceHolders p)) -> String
show = StringSQL -> String
showStringSQL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r p.
Config
-> Table r
-> (Record Flat r -> Restrict (PlaceHolders p))
-> (StringSQL, StringSQL)
fromRestriction Config
defaultConfig forall r. TableDerivable r => Table r
derivedTable
type UpdateTarget p r = Record Flat r -> Assign r (PlaceHolders p)
updateTarget :: (Record Flat r -> Assign r ())
-> UpdateTarget () r
updateTarget :: forall r. (Record Flat r -> Assign r ()) -> UpdateTarget () r
updateTarget = ((forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders ()
unitPH) forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# DEPRECATED updateTarget "old-style API. Use new-style Database.Relational.updateNoPH." #-}
updateTarget' :: (Record Flat r -> Assign r (PlaceHolders p))
-> UpdateTarget p r
updateTarget' :: forall r p.
(Record Flat r -> Assign r (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders p)
updateTarget' = 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 :: 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 Record Flat r
proj = do
(PlaceHolders r
ph0, ()) <- 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 -> forall a. Pi a a
id' forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# Record Flat r
ph)
PlaceHolders p
ph1 <- forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings forall a b. (a -> b) -> a -> b
$ Record Flat r -> Restrict (PlaceHolders p)
rs Record Flat r
proj
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PlaceHolders r
ph0 forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders p
ph1
liftTargetAllColumn :: PersistableWidth r
=> (Record Flat r -> Restrict (PlaceHolders ()))
-> (Record Flat r -> Assign r (PlaceHolders r))
liftTargetAllColumn :: forall r.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders ()))
-> Record Flat r -> Assign r (PlaceHolders r)
liftTargetAllColumn Record Flat r -> Restrict (PlaceHolders ())
rs = \Record Flat r
proj -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) e a. ProductIsoEmpty f e => f (a, e) -> f a
peRight forall a b. (a -> b) -> a -> b
$ 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 ())
rs Record Flat r
proj
{-# DEPRECATED liftTargetAllColumn "old-style API. use Database.Relational.updateAllColumnNoPH instead of this." #-}
liftTargetAllColumn' :: PersistableWidth r
=> (Record Flat r -> Restrict (PlaceHolders p))
-> (Record Flat r -> Assign r (PlaceHolders (r, p)))
liftTargetAllColumn' :: forall r p.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
liftTargetAllColumn' Record Flat r -> Restrict (PlaceHolders p)
rs = 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
updateTargetAllColumn :: PersistableWidth r
=> (Record Flat r -> Restrict ())
-> (Record Flat r -> Assign r (PlaceHolders r))
updateTargetAllColumn :: forall r.
PersistableWidth r =>
(Record Flat r -> Restrict ())
-> Record Flat r -> Assign r (PlaceHolders r)
updateTargetAllColumn = forall r.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders ()))
-> Record Flat r -> Assign r (PlaceHolders r)
liftTargetAllColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. (Record Flat r -> Restrict ()) -> Restriction () r
restriction
{-# DEPRECATED updateTargetAllColumn "Use Database.Relational.updateAllColumnNoPH instead of this." #-}
updateTargetAllColumn' :: PersistableWidth r
=> (Record Flat r -> Restrict (PlaceHolders p))
-> (Record Flat r -> Assign r (PlaceHolders (r, p)))
updateTargetAllColumn' :: forall r p.
PersistableWidth r =>
(Record Flat r -> Restrict (PlaceHolders p))
-> Record Flat r -> Assign r (PlaceHolders (r, p))
updateTargetAllColumn' = 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 :: 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)
q = (StringSQL
qt, [(StringSQL, StringSQL)] -> StringSQL
composeSets (Table r -> [(StringSQL, StringSQL)]
asR Table r
tbl) 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) = forall r a.
Assign r a
-> Config
-> ((a, Table r -> [(StringSQL, StringSQL)]), [Predicate Flat])
Assign.extract (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
sqlFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL
sqlFromUpdateTarget :: forall r p.
Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> StringSQL
sqlFromUpdateTarget Config
config Table r
tbl = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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." #-}
updateFromUpdateTarget :: Config -> Table r -> (Record Flat r -> Assign r (PlaceHolders p)) -> StringSQL
updateFromUpdateTarget :: forall r p.
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 forall a. Semigroup a => a -> a -> a
<> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Semigroup a => a -> a -> a
(<>) (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)
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r p.
Config
-> Table r
-> (Record Flat r -> Assign r (PlaceHolders p))
-> (StringSQL, StringSQL)
fromUpdateTarget Config
defaultConfig forall r. TableDerivable r => Table r
derivedTable
newtype InsertTarget p r = InsertTarget (Register r (PlaceHolders p))
insertTarget :: Register r ()
-> InsertTarget () r
insertTarget :: forall r. Register r () -> InsertTarget () r
insertTarget = forall p r. Register r (PlaceHolders p) -> InsertTarget p r
InsertTarget forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders ()
unitPH)
{-# DEPRECATED insertTarget "old-style API. Use new-style Database.Relational.insertValueNoPH ." #-}
insertTarget' :: Register r (PlaceHolders p)
-> InsertTarget p r
insertTarget' :: forall r p. Register r (PlaceHolders p) -> InsertTarget p r
insertTarget' = forall p r. Register r (PlaceHolders p) -> InsertTarget p r
InsertTarget
piRegister :: PersistableWidth r
=> Pi r r'
-> Register r (PlaceHolders r')
piRegister :: forall r r'.
PersistableWidth r =>
Pi r r' -> Register r (PlaceHolders r')
piRegister Pi r r'
pi' = do
let (PlaceHolders r'
ph', Assignings r ConfigureQuery ()
ma) = forall c a b.
SqlContext c =>
PersistableRecordWidth a
-> (Record c a -> b) -> (PlaceHolders a, b)
pwPlaceholder (forall r ct.
PersistableWidth r =>
Pi r ct -> PersistableRecordWidth ct
Pi.width' Pi r r'
pi') (\Record Flat r'
ph -> Pi r r'
pi' forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# Record Flat r'
ph)
() <- Assignings r ConfigureQuery ()
ma
forall (m :: * -> *) a. Monad m => a -> m a
return PlaceHolders r'
ph'
sqlChunkFromInsertTarget' :: Config
-> Int
-> Table r
-> InsertTarget p r
-> StringSQL
sqlChunkFromInsertTarget' :: forall r p.
Config -> Int -> Table r -> InsertTarget p r -> StringSQL
sqlChunkFromInsertTarget' Config
config Int
sz Table r
tbl (InsertTarget Register r (PlaceHolders p)
q) =
StringSQL
INSERT forall a. Semigroup a => a -> a -> a
<> StringSQL
INTO forall a. Semigroup a => a -> a -> a
<> String -> StringSQL
stringSQL (forall r. Table r -> String
Table.name Table r
tbl) 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) = 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 :: forall r. Config -> Table r -> Int
countChunks Config
config Table r
tbl =
(Int
th forall a. Num a => a -> a -> a
+ Int
w forall a. Num a => a -> a -> a
- Int
1) forall a. Integral a => a -> a -> a
`quot` Int
w
where
th :: Int
th = Config -> Int
chunksInsertSize Config
config
w :: Int
w = forall r. Table r -> Int
Table.width Table r
tbl
sqlChunkFromInsertTarget :: Config
-> Table r
-> InsertTarget p r
-> (StringSQL, Int)
sqlChunkFromInsertTarget :: forall r p.
Config -> Table r -> InsertTarget p r -> (StringSQL, Int)
sqlChunkFromInsertTarget Config
config Table r
tbl InsertTarget p r
it =
(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 = forall r. Config -> Table r -> Int
countChunks Config
config Table r
tbl
sqlFromInsertTarget :: Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget :: forall r p. Config -> Table r -> InsertTarget p r -> StringSQL
sqlFromInsertTarget Config
config = forall r p.
Config -> Int -> Table r -> InsertTarget p r -> StringSQL
sqlChunkFromInsertTarget' Config
config Int
1
sqlChunksFromRecordList :: LiteralSQL r'
=> Config
-> Table r
-> Pi r r'
-> [r']
-> [StringSQL]
sqlChunksFromRecordList :: forall r' r.
LiteralSQL r' =>
Config -> Table r -> Pi r r' -> [r'] -> [StringSQL]
sqlChunksFromRecordList Config
config Table r
tbl Pi r r'
pi' [r']
xs =
[ StringSQL
INSERT forall a. Semigroup a => a -> a -> a
<> StringSQL
INTO forall a. Semigroup a => a -> a -> a
<> String -> StringSQL
stringSQL (forall r. Table r -> String
Table.name Table r
tbl) 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) = forall r a.
Assignings r ConfigureQuery a
-> Config -> (a, Table r -> [(StringSQL, StringSQL)])
Register.extract (Pi r r'
pi' forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value r'
r) Config
config
]
| [r']
rs <- forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr forall {a}. [a] -> Maybe ([a], [a])
step [r']
xs
]
where
n :: Int
n = forall r. Config -> Table r -> Int
countChunks Config
config Table r
tbl
step :: [a] -> Maybe ([a], [a])
step [a]
ys
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
ys