@@ -1,6 +1,8 @@
11{-# LANGUAGE
22 DataKinds
3+ , DeriveFunctor
34 , FlexibleContexts
5+ , FlexibleInstances
46 , PolyKinds
57 , RecordWildCards
68 , ScopedTypeVariables
@@ -11,6 +13,9 @@
1113
1214module Squeel.PostgreSQL.PQ where
1315
16+import Control.Arrow
17+import Control.Monad.Indexed
18+import Control.Monad.Indexed.Trans
1419import Control.Monad.IO.Class
1520import Data.ByteString (ByteString)
1621import Data.Proxy
@@ -28,6 +33,40 @@ newtype Connection db = Connection { unConnection :: LibPQ.Connection }
2833
2934newtype PQ m db0 db1 x = PQ
3035 { runPQ :: Connection db0 -> m (x, Connection db1) }
36+ deriving Functor
37+
38+instance Functor m => IxFunctor (PQ m) where
39+ imap f (PQ g) = PQ $ fmap (first f) . g
40+
41+instance Applicative m => IxPointed (PQ m) where
42+ ireturn x = PQ $ \ conn -> pure (x, conn)
43+
44+instance Monad m => IxApplicative (PQ m) where
45+ iap (PQ f) (PQ x) = PQ $ \ conn -> do
46+ (f', conn') <- f conn
47+ (x', conn'') <- x conn'
48+ return (f' x', conn'')
49+
50+instance Monad m => Applicative (PQ m db db) where
51+ pure = ireturn
52+ (<*>) = iap
53+
54+instance Monad m => IxMonad (PQ m) where
55+ ibind f (PQ x) = PQ $ \ conn -> do
56+ (x', conn') <- x conn
57+ runPQ (f x') conn'
58+
59+instance Monad m => Monad (PQ m db db) where
60+ return = ireturn
61+ (>>=) = flip ibind
62+
63+instance IxMonadTrans PQ where
64+ ilift m = PQ $ \ conn -> do
65+ x <- m
66+ return (x, conn)
67+
68+instance MonadIO io => MonadIO (PQ io db db) where
69+ liftIO = ilift . liftIO
3170
3271connectdb :: MonadIO io => ByteString -> io (Connection db)
3372connectdb = fmap Connection . liftIO . LibPQ.connectdb