@@ -22,20 +22,16 @@ module Squeel.PostgreSQL.PQ where
2222import Control.Exception.Lifted
2323import Control.Monad.Base
2424import Control.Monad.Except
25−import Control.Monad.Trans.Maybe
2625import Control.Monad.Trans.Control
2726import Data.ByteString (ByteString)
2827import Data.Function ((&))
29−import Data.Maybe
30−import Data.Proxy (Proxy)
31−import Data.Text (Text)
3228import Generics.SOP
3329import GHC.Exts hiding (fromList)
3430import GHC.TypeLits
3531
3632import qualified Database.PostgreSQL.LibPQ as LibPQ
3733
38−import Squeel.PostgreSQL.Binary
34+import Squeel.PostgreSQL.Binary2
3935import Squeel.PostgreSQL.Statement
4036import Squeel.PostgreSQL.Schema
4137
@@ -104,28 +100,24 @@ pqThenExec = pqThen . pqExec
104100class Monad m => MonadPQ schema m | m -> schema where
105101
106102 pqExecParams
107− :: (ToOids ps, AllZip HasEncoding ps xs)
108− => Manipulation schema ps ys -> NP I xs -> m (Maybe (Result ys))
103+ :: ToParams x params
104+ => Manipulation schema params ys -> x -> m (Maybe (Result ys))
109105 default pqExecParams
110106 :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)
111− => (ToOids ps, AllZip HasEncoding ps xs)
112− => Manipulation schema ps ys -> NP I xs -> m (Maybe (Result ys))
107+ => ToParams x params
108+ => Manipulation schema params ys -> x -> m (Maybe (Result ys))
113109 pqExecParams manipulation params = lift $ pqExecParams manipulation params
114110
115111 pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))
116− pqExecNil statement = pqExecParams statement Nil
112+ pqExecNil statement = pqExecParams statement ()
117113
118114instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
119115
120− pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) params =
116+ pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
121117 PQ $ \ (Connection conn) -> do
122118 let
123− paramValues = encodings (Proxy :: Proxy ps) params
124− oids = toOids (proxy# :: Proxy# ps)
125− params' =
126− [ Just (oid, param', LibPQ.Binary)
127− | (oid, param') <- zip oids paramValues
128− ]
119+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
120+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
129121 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
130122 return (Result <$> result, Connection conn)
131123
@@ -190,43 +182,25 @@ instance {-# OVERLAPPABLE #-}
190182 (KnownNat n, HasColumnNumber (n-1) columns column)
191183 => HasColumnNumber n (column' : columns) column
192184
193−newtype Value pgs m x = Value { runValue :: Result pgs -> m x }
194− deriving (Functor)
195−instance Applicative m => Applicative (Value pgs m) where
196− pure x = Value $ \ _result -> pure x
197− mf <*> mx = Value $ \ result -> runValue mf result <*> runValue mx result
198−instance Monad m => Monad (Value pgs m) where
199− return = pure
200− mx >>= f = Value $ \ result -> do
201− x <- runValue mx result
202− runValue (f x) result
203−instance MonadTrans (Value pgs) where
204− lift m = Value $ \ _result -> m
205−instance MonadBase b m => MonadBase b (Value pgs m) where
206− liftBase = lift . liftBase
207−
208185getValue
209− :: (HasDecoding pg x, MonadBase IO io)
186+ :: (FromColumnValue colty y, MonadBase IO io)
210187 => RowNumber
211− -> ColumnNumber n pgs pg
212− -> Value pgs (ExceptT Text (MaybeT io)) x
213−getValue (RowNumber r) (UnsafeColumnNumber c :: ColumnNumber n pgs pg) =
214− Value $ \ (Result result) -> do
215− maybeBytestring <- liftBase $ LibPQ.getvalue result r c
216− case maybeBytestring of
217− Nothing -> mzero
218− Just bytestring -> case decodeValue (Proxy :: Proxy pg) bytestring of
219− Left err -> throwError err
220− Right val -> return val
188+ -> ColumnNumber n columns colty
189+ -> Result columns
190+ -> io y
191+getValue
192+ (RowNumber r)
193+ (UnsafeColumnNumber c :: ColumnNumber n columns colty)
194+ (Result result)
195+ = fromColumnValue @colty . K <$>
196+ liftBase (LibPQ.getvalue result r c)
221197
222198getRow
223− :: (AllZip HasDecoding pgs xs, MonadBase IO io)
224− => RowNumber -> Value pgs (ExceptT Text (MaybeT io)) (NP I xs)
225−getRow (RowNumber r) = Value $ \ (Result result :: Result pgs) -> do
226− maybeBytestrings <- traverse (liftBase . LibPQ.getvalue result r)
227− [0 .. fromIntegral (lengthSList (Proxy :: Proxy pgs)) - 1]
228− case fromList (catMaybes maybeBytestrings) of
229− Nothing -> mzero
230− Just bytestrings -> case decodings (Proxy :: Proxy pgs) bytestrings of
231− Left err -> throwError err
232− Right row -> return row
199+ :: (FromRow columns y, MonadBase IO io)
200+ => RowNumber -> Result columns -> io y
201+getRow (RowNumber r) (Result result :: Result columns) = do
202+ let len = fromIntegral (lengthSList (Proxy @columns))
203+ row' <- traverse (liftBase . LibPQ.getvalue result r) [0 .. len - 1]
204+ case fromList row' of
205+ Nothing -> error "getRow: found unexpected length"
206+ Just row -> return $ fromRow @columns row