{-# LANGUAGE FlexibleContexts #-}
module Database.HDBC.Record.Insert (
PreparedInsert, prepare, prepareInsert,
runPreparedInsert, runInsert, mapInsert,
bulkInsert,
bulkInsert',
bulkInsertInterleave,
chunksInsert,
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (unless)
import System.IO.Unsafe (unsafeInterleaveIO)
import Database.HDBC (IConnection, SqlValue)
import Database.Relational (Insert (..), untypeChunkInsert, chunkSizeOfInsert)
import Database.Record (ToSql, fromRecord)
import Database.HDBC.Record.Statement
(prepareNoFetch, withPrepareNoFetch, withUnsafePrepare, PreparedStatement, untypePrepared,
BoundStatement (..), executeNoFetch, runNoFetch, mapNoFetch, executeBoundNoFetch)
type PreparedInsert a = PreparedStatement a ()
prepare :: IConnection conn
=> conn
-> Insert a
-> IO (PreparedInsert a)
prepare = prepareNoFetch
prepareInsert :: IConnection conn
=> conn
-> Insert a
-> IO (PreparedInsert a)
prepareInsert = prepare
runPreparedInsert :: ToSql SqlValue a
=> PreparedInsert a
-> a
-> IO Integer
runPreparedInsert = executeNoFetch
runInsert :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> a
-> IO Integer
runInsert = runNoFetch
mapInsert :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> [a]
-> IO [Integer]
mapInsert = mapNoFetch
chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement ()
chunkBind q ps = BoundStatement { bound = untypePrepared q, params = ps >>= fromRecord }
withPrepareChunksInsert :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> (PreparedInsert a -> PreparedStatement [p] () -> Int -> IO b)
-> IO b
withPrepareChunksInsert conn i0 body =
withPrepareNoFetch conn i0
(\ins -> withUnsafePrepare conn (untypeChunkInsert i0)
(\iChunk -> body ins iChunk $ chunkSizeOfInsert i0) )
chunks :: Int -> [a] -> ([[a]], [a])
chunks n = rec' where
rec' xs
| null tl = if length c == n
then ([c], [])
else ( [], c)
| otherwise = (c : cs, ys) where
(c, tl) = splitAt n xs
(cs, ys) = rec' tl
lazyMapIO :: (a -> IO b) -> [a] -> IO [b]
lazyMapIO _ [] = return []
lazyMapIO f (x:xs) = unsafeInterleaveIO $ (:) <$> f x <*> lazyMapIO f xs
chunksLazyAction :: ToSql SqlValue a
=> [a]
-> PreparedInsert a
-> PreparedStatement [a] ()
-> Int
-> IO ([Integer], [Integer])
chunksLazyAction rs ins iChunk size =
(,)
<$> lazyMapIO (executeBoundNoFetch . chunkBind iChunk) cs
<*> (unsafeInterleaveIO $ mapM (runPreparedInsert ins) xs)
where
(cs, xs) = chunks size rs
bulkInsertInterleave :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> [a]
-> IO ([Integer], [Integer])
bulkInsertInterleave conn ins =
withPrepareChunksInsert conn ins . chunksLazyAction
chunksAction :: ToSql SqlValue a
=> [a]
-> PreparedInsert a
-> PreparedStatement [a] ()
-> Int
-> IO ()
chunksAction rs ins iChunk size = do
(zs, os) <- chunksLazyAction rs ins iChunk size
unless (all (== fromIntegral size) zs)
$ fail "chunksAction: chunks: unexpected result size!"
unless (all (== 1) os)
$ fail "chunksAction: tails: unexpected result size!"
bulkInsert :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> [a]
-> IO ()
bulkInsert conn ins =
withPrepareChunksInsert conn ins . chunksAction
bulkInsert' :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> [a]
-> IO ([Integer], [Integer])
bulkInsert' conn ins rs = do
p@(zs, os) <- withPrepareChunksInsert conn ins $ chunksLazyAction rs
let zl = length zs
ol = length os
zl `seq` ol `seq` return p
{-# DEPRECATED chunksInsert "use bulkInsert' instead of this." #-}
chunksInsert :: (IConnection conn, ToSql SqlValue a)
=> conn
-> Insert a
-> [a]
-> IO [[Integer]]
chunksInsert conn ins rs = do
(zs, os) <- bulkInsert' conn ins rs
return $ map (: []) zs ++ [os]