git.iko.soy/squeal
on dev help sign in
PQ instances
9606759Eitan Chatav
squeel-postgresql/squeel-postgresql.cabal+1
compare with dev
unifiedsplit
@@ -25,6 +25,7 @@ library
25 build-depends: base
25 build-depends: base
26 , aeson
26 , aeson
27 , bytestring
27 , bytestring
28+ , indexed
28 , postgresql-binary
29 , postgresql-binary
29 , postgresql-libpq
30 , postgresql-libpq
30 , scientific
31 , scientific
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+39
@@ -1,6 +1,8 @@
1{-# LANGUAGE
1{-# LANGUAGE
2 DataKinds
2 DataKinds
3+ , DeriveFunctor
3 , FlexibleContexts
4 , FlexibleContexts
5+ , FlexibleInstances
4 , PolyKinds
6 , PolyKinds
5 , RecordWildCards
7 , RecordWildCards
6 , ScopedTypeVariables
8 , ScopedTypeVariables
@@ -11,6 +13,9 @@
11
13
12module Squeel.PostgreSQL.PQ where
14module Squeel.PostgreSQL.PQ where
13
15
16+import Control.Arrow
17+import Control.Monad.Indexed
18+import Control.Monad.Indexed.Trans
14import Control.Monad.IO.Class
19import Control.Monad.IO.Class
15import Data.ByteString (ByteString)
20import Data.ByteString (ByteString)
16import Data.Proxy
21import Data.Proxy
@@ -28,6 +33,40 @@ newtype Connection db = Connection { unConnection :: LibPQ.Connection }
28
33
29newtype PQ m db0 db1 x = PQ
34newtype PQ m db0 db1 x = PQ
30 { runPQ :: Connection db0 -> m (x, Connection db1) }
35 { 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
31
70
32connectdb :: MonadIO io => ByteString -> io (Connection db)
71connectdb :: MonadIO io => ByteString -> io (Connection db)
33connectdb = fmap Connection . liftIO . LibPQ.connectdb
72connectdb = fmap Connection . liftIO . LibPQ.connectdb
squeel-postgresql/src/Squeel/PostgreSQL/Value.hs+2−2
@@ -17,7 +17,6 @@ import Control.Arrow (left)
17import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)
17import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)
18import Data.Bits (Bits)
18import Data.Bits (Bits)
19import Data.ByteString (ByteString)
19import Data.ByteString (ByteString)
20−import Data.ByteString.Builder
21import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
20import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
22import Data.Int (Int16,Int32,Int64)
21import Data.Int (Int16,Int32,Int64)
23import Data.Proxy
22import Data.Proxy
@@ -25,6 +24,7 @@ import Data.Vinyl
25import Data.Vinyl.Functor
24import Data.Vinyl.Functor
26import PostgreSQL.Binary.Decoder (Decoder)
25import PostgreSQL.Binary.Decoder (Decoder)
27import qualified PostgreSQL.Binary.Decoder as Decoder
26import qualified PostgreSQL.Binary.Decoder as Decoder
27+import PostgreSQL.Binary.Encoder (Encoder)
28import qualified PostgreSQL.Binary.Encoder as Encoder
28import qualified PostgreSQL.Binary.Encoder as Encoder
29import Data.Proxy (Proxy)
29import Data.Proxy (Proxy)
30import Data.Scientific (Scientific)
30import Data.Scientific (Scientific)
@@ -82,7 +82,7 @@ instance FromValue ('PGType "interval") DiffTime where
82 fromValue _ = Decoder.interval_int
82 fromValue _ = Decoder.interval_int
83
83
84class ToValue x (pg :: PGType) where
84class ToValue x (pg :: PGType) where
85− toValue :: Proxy pg -> x -> Builder
85+ toValue :: Proxy pg -> Encoder x
86instance ToValue Int16 ('PGType "int2") where
86instance ToValue Int16 ('PGType "int2") where
87 toValue _ = Encoder.int2_int16
87 toValue _ = Encoder.int2_int16
88instance ToValue Int32 ('PGType "int4") where
88instance ToValue Int32 ('PGType "int4") where