@@ -33,6 +33,7 @@ import Data.Monoid (mappend)
33import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime)
33import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime)
34import Data.Typeable (Typeable)
34import Data.Typeable (Typeable)
35import Data.Word (Word, Word8, Word16, Word32, Word64)
35import Data.Word (Word, Word8, Word16, Word32, Word64)
36+import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
36import Database.PostgreSQL.Simple.Types
37import Database.PostgreSQL.Simple.Types
37import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
38import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8
38import qualified Data.ByteString as SB
39import qualified Data.ByteString as SB
@@ -279,3 +280,59 @@ toJSONField = toField . JSON.toJSON
279inQuotes :: Builder -> Builder
280inQuotes :: Builder -> Builder
280inQuotes b = quote `mappend` b `mappend` quote
281inQuotes b = quote `mappend` b `mappend` quote
281 where quote = Utf8.fromChar '\''
282 where quote = Utf8.fromChar '\''
284+interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
285+interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as
286+{-# INLINE interleaveFoldr #-}
288+instance ToRow a => ToField (Values a) where
289+ toField (Values types rows) =
293+ (_:_) -> values $ typedRow (repeat (lit "null"))
296+ (_:_) -> case types of
297+ [] -> values $ untypedRows rows [litC ')']
298+ (_:_) -> values $ typedRows rows types [litC ')']
300+ err = "Database.PostgreSQL.Simple.toField :: Values -> Action either values or types must be non-empty"
301+ lit = Plain . fromByteString
302+ litC = Plain . fromChar
303+ values x = Many (lit "(VALUES ": x)
305+ typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]
306+ typedField (val,typ) rest = val : lit "::" : toField typ : rest
308+ typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]
309+ typedRow (val:vals) (typ:typs) rest =
311+ typedField (val,typ) ( interleaveFoldr
317+ untypedRow :: [Action] -> [Action] -> [Action]
318+ untypedRow (val:vals) rest =
326+ typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
327+ typedRows (val:vals) types rest =
328+ typedRow (toRow val) types (litC ',' : untypedRows vals rest)
330+ untypedRows :: ToRow a => [a] -> [Action] -> [Action]
331+ untypedRows [] rest = rest
332+ untypedRows (val:vals) rest =
333+ untypedRow (toRow val) $
335+ (untypedRow . toRow)