git.iko.soy/squeal
on dev help sign in
Merge pull request #23 from echatav/generics
49cbdefEitan Chatav
squeel-postgresql/exe/Example.hs+28−12
compare with dev
unifiedsplit
@@ -3,6 +3,7 @@
3 , MagicHash
3 , MagicHash
4 , OverloadedLabels
4 , OverloadedLabels
5 , OverloadedStrings
5 , OverloadedStrings
6+ , ScopedTypeVariables
6 , TypeOperators
7 , TypeOperators
7#-}
8#-}
8
9
@@ -10,10 +11,12 @@ module Main (main) where
10
11
11import Control.Category ((>>>))
12import Control.Category ((>>>))
12import Control.Monad.Base
13import Control.Monad.Base
14+import Control.Monad.Except
15+import Control.Monad.Trans.Maybe
13import Data.Function ((&))
16import Data.Function ((&))
14import Data.Int
17import Data.Int
15import Data.Monoid
18import Data.Monoid
16−import Data.Vinyl
19+import Generics.SOP
17import Squeel.PostgreSQL
20import Squeel.PostgreSQL
18
21
19import qualified Data.ByteString.Char8 as Char8
22import qualified Data.ByteString.Char8 as Char8
@@ -29,29 +32,42 @@ main = do
29 connection1 <- flip execPQ connection0 $ pqExec $
32 connection1 <- flip execPQ connection0 $ pqExec $
30 createTable #students
33 createTable #students
31 ( (text & notNull) `As` #name
34 ( (text & notNull) `As` #name
32− :& RNil )
35+ :* Nil )
33 >>>
36 >>>
34 createTable #table1
37 createTable #table1
35 ( (int4 & notNull) `As` #col1
38 ( (int4 & notNull) `As` #col1
36− :& (int4 & notNull) `As` #col2
39+ :* (int4 & notNull) `As` #col2
37− :& RNil )
40+ :* Nil )
38 connection2 <- flip execPQ connection1 $ do
41 connection2 <- flip execPQ connection1 $ do
39 _insertTable1Result <- pqExec $
42 _insertTable1Result <- pqExec $
40− insertInto #table1 ( 1 `As` #col1 :& 2 `As` #col2 :& RNil )
43+ insertInto #table1 ( 1 `As` #col1 :* 2 `As` #col2 :* Nil )
41 >>>
44 >>>
42− insertInto #table1 ( 3 `As` #col1 :& 4 `As` #col2 :& RNil )
45+ insertInto #table1 ( 3 `As` #col1 :* 4 `As` #col2 :* Nil )
43− Just selectTable1Result <- flip pqExecParams RNil $
46+ Just selectTable1Result <- flip pqExecParams Nil $
44 (select $ starFrom #table1 :: Statement '[] Columns Tables Tables)
47 (select $ starFrom #table1 :: Statement '[] Columns Tables Tables)
45− Just (Right value00) <- getvalue selectTable1Result (RowNumber 0) colNum0
48+ Just (Right value00) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
49+ getValue (RowNumber 0) colNum0
46− Just (Right value01) <- getvalue selectTable1Result (RowNumber 0) colNum1
50+ Just (Right value01) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
51+ getValue (RowNumber 0) colNum1
47− Just (Right value10) <- getvalue selectTable1Result (RowNumber 1) colNum0
52+ Just (Right value10) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
53+ getValue (RowNumber 1) colNum0
48− Just (Right value11) <- getvalue selectTable1Result (RowNumber 1) colNum1
54+ Just (Right value11) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
55+ getValue (RowNumber 1) colNum1
56+ Just (Right row0) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
57+ getRow (RowNumber 0)
58+ Just (Right row1) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
59+ getRow (RowNumber 1)
49 liftBase $ do
60 liftBase $ do
50 print (value00 :: Int32)
61 print (value00 :: Int32)
51 print (value01 :: Int32)
62 print (value01 :: Int32)
52 print (value10 :: Int32)
63 print (value10 :: Int32)
53 print (value11 :: Int32)
64 print (value11 :: Int32)
54− finish connection2
65+ print (row0 :: NP I '[Int32,Int32])
66+ print (row1 :: NP I '[Int32,Int32])
67+ connection3 :: Connection '[] <- flip execPQ connection2 $ pqExec $
68+ (dropTable #table1 :: Statement '[] '[] Tables '["students" ::: StudentsColumns])
69+ >>> dropTable #students
70+ finish connection3
55
71
56type Columns =
72type Columns =
57 '[ "col1" ::: 'Required ('NotNull 'PGInt4)
73 '[ "col1" ::: 'Required ('NotNull 'PGInt4)
squeel-postgresql/squeel-postgresql.cabal+6−3
@@ -25,6 +25,7 @@ library
25 , base
25 , base
26 , Boolean
26 , Boolean
27 , bytestring
27 , bytestring
28+ , generics-sop
28 , lifted-base
29 , lifted-base
29 , monad-control
30 , monad-control
30 , mtl
31 , mtl
@@ -33,9 +34,9 @@ library
33 , scientific
34 , scientific
34 , text
35 , text
35 , time
36 , time
37+ , transformers
36 , transformers-base
38 , transformers-base
37 , uuid
39 , uuid
38− , vinyl
39
40
40test-suite squeel-postgresql-test
41test-suite squeel-postgresql-test
41 default-language: Haskell2010
42 default-language: Haskell2010
@@ -49,9 +50,9 @@ test-suite squeel-postgresql-test
49 build-depends:
50 build-depends:
50 base
51 base
51 , Boolean
52 , Boolean
53+ , generics-sop
52 , hspec
54 , hspec
53 , squeel-postgresql
55 , squeel-postgresql
54− , vinyl
55
56
56executable squeel-postgresql-example
57executable squeel-postgresql-example
57 default-language: Haskell2010
58 default-language: Haskell2010
@@ -61,9 +62,11 @@ executable squeel-postgresql-example
61 build-depends:
62 build-depends:
62 base
63 base
63 , bytestring
64 , bytestring
65+ , generics-sop
66+ , mtl
64 , squeel-postgresql
67 , squeel-postgresql
68+ , transformers
65 , transformers-base
69 , transformers-base
66− , vinyl
67
70
68source-repository head
71source-repository head
69 type: git
72 type: git
squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+115−117
@@ -1,7 +1,9 @@
1{-# LANGUAGE
1{-# LANGUAGE
2 DataKinds
2 DataKinds
3+ , FlexibleContexts
3 , FlexibleInstances
4 , FlexibleInstances
4 , GADTs
5 , GADTs
6+ , LambdaCase
5 , MagicHash
7 , MagicHash
6 , MultiParamTypeClasses
8 , MultiParamTypeClasses
7 , PolyKinds
9 , PolyKinds
@@ -11,137 +13,133 @@
11
13
12module Squeel.PostgreSQL.Binary where
14module Squeel.PostgreSQL.Binary where
13
15
14−import Control.Arrow (left)
15−import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)
16import Data.ByteString (ByteString)
16import Data.ByteString (ByteString)
17import Data.Int (Int16,Int32,Int64)
17import Data.Int (Int16,Int32,Int64)
18−import Data.Vinyl
18+import Generics.SOP
19−import Data.Vinyl.Functor
20−import PostgreSQL.Binary.Decoding (Value)
21−import PostgreSQL.Binary.Encoding (Encoding)
22import Data.Scientific (Scientific)
19import Data.Scientific (Scientific)
23import Data.Text (Text)
20import Data.Text (Text)
24import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
21import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
25import Data.UUID (UUID)
22import Data.UUID (UUID)
26−import GHC.Exts
27
23
28−import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
24+import qualified Data.Aeson as Aeson
29−import qualified Data.Text as Text (pack)
25+import qualified Data.ByteString.Lazy as Lazy (ByteString)
30import qualified Data.Text.Lazy as Lazy (Text)
26import qualified Data.Text.Lazy as Lazy (Text)
31import qualified PostgreSQL.Binary.Decoding as Decoder
27import qualified PostgreSQL.Binary.Decoding as Decoder
32import qualified PostgreSQL.Binary.Encoding as Encoder
28import qualified PostgreSQL.Binary.Encoding as Encoder
33
29
34import Squeel.PostgreSQL.Schema
30import Squeel.PostgreSQL.Schema
35
31
36−decodeValue :: FromValue pg x => Proxy# pg -> ByteString -> Either Text x
32+decodeValue :: HasDecoding pg x => proxy pg -> ByteString -> Either Text x
37−decodeValue p = Decoder.valueParser $ fromValue p
33+decodeValue p = Decoder.valueParser $ decoding p
38
34
39−class FromValue pg x where
35+class HasDecoding pg x where
40− fromValue :: Proxy# pg -> Value x
36+ decoding :: proxy pg -> Decoder.Value x
41−instance FromValue 'PGInt2 Int16 where
37+instance HasDecoding (column ::: 'Required ('NotNull 'PGInt2)) Int16 where
42− fromValue _ = Decoder.int
38+ decoding _ = Decoder.int
43−instance FromValue 'PGInt4 Int32 where
39+instance HasDecoding (column ::: 'Required ('NotNull 'PGInt4)) Int32 where
44− fromValue _ = Decoder.int
40+ decoding _ = Decoder.int
45−instance FromValue 'PGInt8 Int64 where
41+instance HasDecoding (column ::: 'Required ('NotNull 'PGInt8)) Int64 where
46− fromValue _ = Decoder.int
42+ decoding _ = Decoder.int
47−instance FromValue 'PGFloat4 Float where
43+instance HasDecoding (column ::: 'Required ('NotNull 'PGFloat4)) Float where
48− fromValue _ = Decoder.float4
44+ decoding _ = Decoder.float4
49−instance FromValue 'PGFloat8 Double where
45+instance HasDecoding (column ::: 'Required ('NotNull 'PGFloat8)) Double where
50− fromValue _ = Decoder.float8
46+ decoding _ = Decoder.float8
51−instance FromValue 'PGBool Bool where
47+instance HasDecoding (column ::: 'Required ('NotNull 'PGBool)) Bool where
52− fromValue _ = Decoder.bool
48+ decoding _ = Decoder.bool
53−instance FromValue 'PGBytea ByteString where
49+instance HasDecoding (column ::: 'Required ('NotNull 'PGBytea)) ByteString where
54− fromValue _ = Decoder.bytea_strict
50+ decoding _ = Decoder.bytea_strict
55−instance FromValue 'PGBytea Lazy.ByteString where
51+instance HasDecoding (column ::: 'Required ('NotNull 'PGBytea)) Lazy.ByteString where
56− fromValue _ = Decoder.bytea_lazy
52+ decoding _ = Decoder.bytea_lazy
57−instance FromValue 'PGText Text where
53+instance HasDecoding (column ::: 'Required ('NotNull 'PGText)) Text where
58− fromValue _ = Decoder.text_strict
54+ decoding _ = Decoder.text_strict
59−instance FromValue 'PGText Lazy.Text where
55+instance HasDecoding (column ::: 'Required ('NotNull 'PGText)) Lazy.Text where
60− fromValue _ = Decoder.text_lazy
56+ decoding _ = Decoder.text_lazy
61−instance FromValue ('PGChar 1) Char where
57+instance HasDecoding (column ::: 'Required ('NotNull ('PGChar 1))) Char where
62− fromValue _ = Decoder.char
58+ decoding _ = Decoder.char
63−instance FromValue 'PGNumeric Scientific where
59+instance HasDecoding (column ::: 'Required ('NotNull 'PGNumeric)) Scientific where
64− fromValue _ = Decoder.numeric
60+ decoding _ = Decoder.numeric
65−instance FromValue 'PGUuid UUID where
61+instance HasDecoding (column ::: 'Required ('NotNull 'PGUuid)) UUID where
66− fromValue _ = Decoder.uuid
62+ decoding _ = Decoder.uuid
67−instance FromJSON x => FromValue 'PGJson x where
63+instance HasDecoding (column ::: 'Required ('NotNull 'PGJson)) Aeson.Value where
68− fromValue _ = Decoder.json_bytes (left Text.pack . eitherDecodeStrict)
64+ decoding _ = Decoder.json_ast
69−instance FromJSON x => FromValue 'PGJsonb x where
65+instance HasDecoding (column ::: 'Required ('NotNull 'PGJsonb)) Aeson.Value where
70− fromValue _ = Decoder.jsonb_bytes (left Text.pack . eitherDecodeStrict)
66+ decoding _ = Decoder.jsonb_ast
71−instance FromValue 'PGDate Day where
67+instance HasDecoding (column ::: 'Required ('NotNull 'PGDate)) Day where
72− fromValue _ = Decoder.date
68+ decoding _ = Decoder.date
73−instance FromValue 'PGTime TimeOfDay where
69+instance HasDecoding (column ::: 'Required ('NotNull 'PGTime)) TimeOfDay where
74− fromValue _ = Decoder.time_int
70+ decoding _ = Decoder.time_int
75−instance FromValue 'PGTimeTZ (TimeOfDay, TimeZone) where
71+instance HasDecoding (column ::: 'Required ('NotNull 'PGTimeTZ)) (TimeOfDay, TimeZone) where
76− fromValue _ = Decoder.timetz_int
72+ decoding _ = Decoder.timetz_int
77−instance FromValue 'PGTimestamp LocalTime where
73+instance HasDecoding (column ::: 'Required ('NotNull 'PGTimestamp)) LocalTime where
78− fromValue _ = Decoder.timestamp_int
74+ decoding _ = Decoder.timestamp_int
79−instance FromValue 'PGTimestampTZ UTCTime where
75+instance HasDecoding (column ::: 'Required ('NotNull 'PGTimestampTZ)) UTCTime where
80− fromValue _ = Decoder.timestamptz_int
76+ decoding _ = Decoder.timestamptz_int
81−instance FromValue 'PGInterval DiffTime where
77+instance HasDecoding (column ::: 'Required ('NotNull 'PGInterval)) DiffTime where
82− fromValue _ = Decoder.interval_int
78+ decoding _ = Decoder.interval_int
83−instance FromValue pg ty => FromValue (column ::: 'Required ('NotNull pg)) ty where
84− fromValue _ = fromValue (proxy# :: Proxy# pg)
85
79
86−class FromValues pgs xs where
80+decodings
81+ :: AllZip HasDecoding pgs xs
82+ => proxy pgs
87− decodeValues :: Proxy# pgs -> Rec (Const ByteString) xs -> Rec (Either Text) xs
83+ -> NP (K ByteString) xs -> Either Text (NP I xs)
88−instance FromValues '[] '[] where decodeValues _ _ = RNil
84+decodings _ Nil = return Nil
89−instance (FromValue pg x, FromValues pgs xs)
85+decodings (_ :: proxy pgs) (K bytestring :* bytestrings) =
90− => FromValues (pg ': pgs) (x ': xs) where
86+ case (hpure Proxy :: NP Proxy pgs) of
91− decodeValues _ (Const result :& results) =
87+ proxy :* proxies -> (:*)
92− decodeValue (proxy# :: Proxy# pg) result
88+ <$> (I <$> Decoder.valueParser (decoding proxy) bytestring)
93− :& decodeValues (proxy# :: Proxy# pgs) results
89+ <*> decodings proxies bytestrings
94
90
95−class ToValue x pg where
91+class HasEncoding pg x where
96− toValue :: Proxy# pg -> x -> Encoding
92+ encoding :: proxy pg -> x -> Encoder.Encoding
97−instance ToValue Int16 'PGInt2 where
93+instance HasEncoding ('Required ('NotNull 'PGInt2)) Int16 where
98− toValue _ = Encoder.int2_int16
94+ encoding _ = Encoder.int2_int16
99−instance ToValue Int32 'PGInt4 where
95+instance HasEncoding ('Required ('NotNull 'PGInt4)) Int32 where
100− toValue _ = Encoder.int4_int32
96+ encoding _ = Encoder.int4_int32
101−instance ToValue Int64 'PGInt8 where
97+instance HasEncoding ('Required ('NotNull 'PGInt8)) Int64 where
102− toValue _ = Encoder.int8_int64
98+ encoding _ = Encoder.int8_int64
103−instance ToValue Float 'PGFloat4 where
99+instance HasEncoding ('Required ('NotNull 'PGFloat4)) Float where
104− toValue _ = Encoder.float4
100+ encoding _ = Encoder.float4
105−instance ToValue Double 'PGFloat8 where
101+instance HasEncoding ('Required ('NotNull 'PGFloat8)) Double where
106− toValue _ = Encoder.float8
102+ encoding _ = Encoder.float8
107−instance ToValue Bool 'PGBool where
103+instance HasEncoding ('Required ('NotNull 'PGBool)) Bool where
108− toValue _ = Encoder.bool
104+ encoding _ = Encoder.bool
109−instance ToValue ByteString 'PGBytea where
105+instance HasEncoding ('Required ('NotNull 'PGBytea)) ByteString where
110− toValue _ = Encoder.bytea_strict
106+ encoding _ = Encoder.bytea_strict
111−instance ToValue Lazy.ByteString 'PGBytea where
107+instance HasEncoding ('Required ('NotNull 'PGBytea)) Lazy.ByteString where
112− toValue _ = Encoder.bytea_lazy
108+ encoding _ = Encoder.bytea_lazy
113−instance ToValue Text 'PGText where
109+instance HasEncoding ('Required ('NotNull 'PGText)) Text where
114− toValue _ = Encoder.text_strict
110+ encoding _ = Encoder.text_strict
115−instance ToValue Lazy.Text 'PGText where
111+instance HasEncoding ('Required ('NotNull 'PGText)) Lazy.Text where
116− toValue _ = Encoder.text_lazy
112+ encoding _ = Encoder.text_lazy
117−instance ToValue Char ('PGChar 1) where
113+instance HasEncoding ('Required ('NotNull ('PGChar 1))) Char where
118− toValue _ = Encoder.char_utf8
114+ encoding _ = Encoder.char_utf8
119−instance ToValue Scientific 'PGNumeric where
115+instance HasEncoding ('Required ('NotNull 'PGNumeric)) Scientific where
120− toValue _ = Encoder.numeric
116+ encoding _ = Encoder.numeric
121−instance ToValue UUID 'PGUuid where
117+instance HasEncoding ('Required ('NotNull 'PGUuid)) UUID where
122− toValue _ = Encoder.uuid
118+ encoding _ = Encoder.uuid
123−instance ToJSON x => ToValue x 'PGJson where
119+instance HasEncoding ('Required ('NotNull 'PGJson)) Aeson.Value where
124− toValue _ = Encoder.json_bytes . Lazy.toStrict . encode
120+ encoding _ = Encoder.json_ast
125−instance ToJSON x => ToValue x 'PGJsonb where
121+instance HasEncoding ('Required ('NotNull 'PGJsonb)) Aeson.Value where
126− toValue _ = Encoder.jsonb_bytes . Lazy.toStrict . encode
122+ encoding _ = Encoder.jsonb_ast
127−instance ToValue Day 'PGDate where
123+instance HasEncoding ('Required ('NotNull 'PGDate)) Day where
128− toValue _ = Encoder.date
124+ encoding _ = Encoder.date
129−instance ToValue TimeOfDay 'PGTime where
125+instance HasEncoding ('Required ('NotNull 'PGTime)) TimeOfDay where
130− toValue _ = Encoder.time_int
126+ encoding _ = Encoder.time_int
131−instance ToValue (TimeOfDay, TimeZone) 'PGTimeTZ where
127+instance HasEncoding ('Required ('NotNull 'PGTimeTZ)) (TimeOfDay, TimeZone) where
132− toValue _ = Encoder.timetz_int
128+ encoding _ = Encoder.timetz_int
133−instance ToValue LocalTime 'PGTimestamp where
129+instance HasEncoding ('Required ('NotNull 'PGTimestamp)) LocalTime where
134− toValue _ = Encoder.timestamp_int
130+ encoding _ = Encoder.timestamp_int
135−instance ToValue UTCTime 'PGTimestampTZ where
131+instance HasEncoding ('Required ('NotNull 'PGTimestampTZ)) UTCTime where
136− toValue _ = Encoder.timestamptz_int
132+ encoding _ = Encoder.timestamptz_int
137−instance ToValue DiffTime 'PGInterval where
133+instance HasEncoding ('Required ('NotNull 'PGInterval)) DiffTime where
138− toValue _ = Encoder.interval_int
134+ encoding _ = Encoder.interval_int
139
135
140−class ToValues xs pgs where
136+encodings
141− toValues :: Proxy# pgs -> Rec Identity xs -> [ByteString]
137+ :: AllZip HasEncoding pgs xs
142−instance ToValues '[] '[] where toValues _ _ = []
138+ => proxy pgs
143−instance (ToValue x pg, ToValues xs pgs)
139+ -> NP I xs
144− => ToValues (x ': xs) (pg ': pgs) where
140+ -> [ByteString]
145− toValues _ (Identity x :& xs)
141+encodings _ Nil = []
142+encodings (_ :: proxy pgs) (I x :* xs) =
143+ case (hpure Proxy :: NP Proxy pgs) of
146− = Encoder.encodingBytes ((toValue (proxy# :: Proxy# pg)) x)
144+ proxy :* proxies -> Encoder.encodingBytes (encoding proxy x)
147− : toValues (proxy# :: Proxy# pgs) xs
145+ : encodings proxies xs
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+56−25
@@ -10,6 +10,7 @@
10 , MultiParamTypeClasses
10 , MultiParamTypeClasses
11 , RankNTypes
11 , RankNTypes
12 , ScopedTypeVariables
12 , ScopedTypeVariables
13+ , TypeApplications
13 , TypeFamilies
14 , TypeFamilies
14 , TypeOperators
15 , TypeOperators
15 , UndecidableInstances
16 , UndecidableInstances
@@ -19,13 +20,15 @@ module Squeel.PostgreSQL.PQ where
19
20
20import Control.Exception.Lifted
21import Control.Exception.Lifted
21import Control.Monad.Base
22import Control.Monad.Base
22−import Control.Monad.Trans
23+import Control.Monad.Except
24+import Control.Monad.Trans.Maybe
23import Control.Monad.Trans.Control
25import Control.Monad.Trans.Control
24import Data.ByteString (ByteString)
26import Data.ByteString (ByteString)
27+import Data.Maybe
28+import Data.Proxy (Proxy)
25import Data.Text (Text)
29import Data.Text (Text)
26−import Data.Vinyl
30+import Generics.SOP
27−import Data.Vinyl.Functor
28−import GHC.Exts
31+import GHC.Exts hiding (fromList)
29import GHC.TypeLits
32import GHC.TypeLits
30
33
31import qualified Database.PostgreSQL.LibPQ as LibPQ
34import qualified Database.PostgreSQL.LibPQ as LibPQ
@@ -70,9 +73,9 @@ class MonadPQ pq where
70 -> pq db0 db1 io (Maybe (Result '[]))
73 -> pq db0 db1 io (Maybe (Result '[]))
71
74
72 pqExecParams
75 pqExecParams
73− :: (MonadBase IO io, ToOids ps, ToValues xs ps)
76+ :: (MonadBase IO io, ToOids ps, AllZip HasEncoding ps xs, All Top ps)
74 => Statement ps ys db0 db1
77 => Statement ps ys db0 db1
75− -> Rec Identity xs
78+ -> NP I xs
76 -> pq db0 db1 io (Maybe (Result ys))
79 -> pq db0 db1 io (Maybe (Result ys))
77
80
78 pqPrepare
81 pqPrepare
@@ -82,9 +85,9 @@ class MonadPQ pq where
82 -> pq db0 db1 io (Maybe (Result []), PreparedStatement ps xs db0 db1)
85 -> pq db0 db1 io (Maybe (Result []), PreparedStatement ps xs db0 db1)
83
86
84 pqExecPrepared
87 pqExecPrepared
85− :: (MonadBase IO io, ToValues xs ps)
88+ :: (MonadBase IO io, AllZip HasEncoding ps xs, All Top ps)
86 => PreparedStatement ps ys db0 db1
89 => PreparedStatement ps ys db0 db1
87− -> Rec Identity xs
90+ -> NP I xs
88 -> pq db0 db1 io (Maybe (Result ys))
91 -> pq db0 db1 io (Maybe (Result ys))
89
92
90instance MonadPQ PQ where
93instance MonadPQ PQ where
@@ -105,12 +108,11 @@ instance MonadPQ PQ where
105 pqExecParams (UnsafeStatement q :: Statement ps ys db0 db1) params =
108 pqExecParams (UnsafeStatement q :: Statement ps ys db0 db1) params =
106 PQ $ \ (Connection conn) -> do
109 PQ $ \ (Connection conn) -> do
107 let
110 let
111+ paramValues = encodings (Proxy :: Proxy ps) params
112+ oids = toOids (proxy# :: Proxy# ps)
108 params' =
113 params' =
109 [ Just (oid, param', LibPQ.Binary)
114 [ Just (oid, param', LibPQ.Binary)
110− | (oid, param') <-
115+ | (oid, param') <- zip oids paramValues
111− zip
112− (toOids (proxy# :: Proxy# ps))
113− (toValues (proxy# :: Proxy# ps) params)
114 ]
116 ]
115 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
117 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
116 return (Result <$> result, Connection conn)
118 return (Result <$> result, Connection conn)
@@ -127,10 +129,8 @@ instance MonadPQ PQ where
127 pqExecPrepared (q :: PreparedStatement ps ys db0 db1) params =
129 pqExecPrepared (q :: PreparedStatement ps ys db0 db1) params =
128 PQ $ \ (Connection conn) -> do
130 PQ $ \ (Connection conn) -> do
129 let
131 let
130− params' =
132+ paramValues = encodings (Proxy :: Proxy ps) params
131− [ Just (param', LibPQ.Binary)
133+ params' = [ Just (param', LibPQ.Binary) | param' <- paramValues ]
132− | param' <- toValues (proxy# :: Proxy# ps) params
133− ]
134 result <- liftBase $
134 result <- liftBase $
135 LibPQ.execPrepared conn (renderPreparedStatement q) params' LibPQ.Binary
135 LibPQ.execPrepared conn (renderPreparedStatement q) params' LibPQ.Binary
136 return (Result <$> result, Connection conn)
136 return (Result <$> result, Connection conn)
@@ -203,12 +203,43 @@ colNum3 = colNum (proxy# :: Proxy# 3)
203colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4
203colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4
204colNum4 = colNum (proxy# :: Proxy# 4)
204colNum4 = colNum (proxy# :: Proxy# 4)
205
205
206−getvalue
206+newtype Value pgs m x = Value { runValue :: Result pgs -> m x }
207− :: (FromValue x y, MonadBase IO io)
207+ deriving (Functor)
208− => Result xs
208+instance Applicative m => Applicative (Value pgs m) where
209− -> RowNumber
209+ pure x = Value $ \ _result -> pure x
210− -> ColumnNumber xs x
210+ mf <*> mx = Value $ \ result -> runValue mf result <*> runValue mx result
211− -> io (Maybe (Either Text y))
211+instance Monad m => Monad (Value pgs m) where
212+ return = pure
213+ mx >>= f = Value $ \ result -> do
214+ x <- runValue mx result
215+ runValue (f x) result
216+instance MonadTrans (Value pgs) where
217+ lift m = Value $ \ _result -> m
218+instance MonadBase b m => MonadBase b (Value pgs m) where
219+ liftBase = lift . liftBase
220+
221+getValue
222+ :: (HasDecoding pg x, MonadBase IO io)
223+ => RowNumber
224+ -> ColumnNumber pgs pg
225+ -> Value pgs (ExceptT Text (MaybeT io)) x
212−getvalue (Result result) (RowNumber r) (ColumnNumber c :: ColumnNumber xs x) =
226+getValue (RowNumber r) (ColumnNumber c :: ColumnNumber pgs pg) =
213− liftBase $ fmap (fmap (decodeValue (proxy# :: Proxy# x)))
227+ Value $ \ (Result result) -> do
228+ maybeBytestring <- liftBase $ LibPQ.getvalue result r c
229+ case maybeBytestring of
230+ Nothing -> mzero
231+ Just bytestring -> case decodeValue (Proxy :: Proxy pg) bytestring of
232+ Left err -> throwError err
233+ Right val -> return val
234+
235+getRow
236+ :: (AllZip HasDecoding pgs xs, MonadBase IO io)
237+ => RowNumber -> Value pgs (ExceptT Text (MaybeT io)) (NP I xs)
238+getRow (RowNumber r) = Value $ \ (Result result :: Result pgs) -> do
214− (LibPQ.getvalue' result r c)
239+ maybeBytestrings <- traverse (liftBase . LibPQ.getvalue result r)
240+ [0 .. fromIntegral (lengthSList (Proxy :: Proxy pgs)) - 1]
241+ case fromList (catMaybes maybeBytestrings) of
242+ Nothing -> mzero
243+ Just bytestrings -> case decodings (Proxy :: Proxy pgs) bytestrings of
244+ Left err -> throwError err
245+ Right row -> return row
squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+35−30
@@ -20,8 +20,7 @@ import Data.ByteString (ByteString)
20import Data.Maybe
20import Data.Maybe
21import Data.Monoid
21import Data.Monoid
22import Data.String
22import Data.String
23−import Data.Vinyl
23+import Generics.SOP
24−import Data.Vinyl.Functor
25import GHC.Exts
24import GHC.Exts
26import GHC.OverloadedLabels
25import GHC.OverloadedLabels
27import GHC.TypeLits
26import GHC.TypeLits
@@ -84,6 +83,11 @@ Alias table &. Alias column = UnsafeExpression $
84def :: Expression params '[] ('Optional (nullity ty))
83def :: Expression params '[] ('Optional (nullity ty))
85def = UnsafeExpression "DEFAULT"
84def = UnsafeExpression "DEFAULT"
86
85
86+notDef
87+ :: Expression params '[] ('Required (nullity ty))
88+ -> Expression params '[] ('Optional (nullity ty))
89+notDef = UnsafeExpression . renderExpression
90+
87null :: Expression params tables (optionality ('Null ty))
91null :: Expression params tables (optionality ('Null ty))
88null = UnsafeExpression "NULL"
92null = UnsafeExpression "NULL"
89
93
@@ -117,8 +121,8 @@ unsafeFunction
117 :: ByteString
121 :: ByteString
118 -> Expression params tables xty
122 -> Expression params tables xty
119 -> Expression params tables yty
123 -> Expression params tables yty
120−unsafeFunction fn x = UnsafeExpression $ mconcat
124+unsafeFunction fun x = UnsafeExpression $ mconcat
121− [fn, "(", renderExpression x, ")"]
125+ [fun, "(", renderExpression x, ")"]
122
126
123instance PGNum ty => Num (Expression params tables ('Required (nullity ty))) where
127instance PGNum ty => Num (Expression params tables ('Required (nullity ty))) where
124 (+) = unsafeBinaryOp "+"
128 (+) = unsafeBinaryOp "+"
@@ -407,7 +411,8 @@ Alias tab `dotStarFrom` tabs = UnsafeSelection $
407 fromString (symbolVal' tab) <> ".* FROM " <> renderFrom tabs
411 fromString (symbolVal' tab) <> ".* FROM " <> renderFrom tabs
408
412
409from
413from
414+ :: SListI columns
410− :: Rec (Aliased (Expression params tables)) columns
415+ => NP (Aliased (Expression params tables)) columns
411 -> From params schema tables
416 -> From params schema tables
412 -> Selection params schema columns
417 -> Selection params schema columns
413list `from` tabs = UnsafeSelection $
418list `from` tabs = UnsafeSelection $
@@ -415,8 +420,8 @@ list `from` tabs = UnsafeSelection $
415 where
420 where
416 renderList
421 renderList
417 = ByteString.intercalate ", "
422 = ByteString.intercalate ", "
418− . recordToList
423+ . hcollapse
419− . rmap (Const . renderAliased renderExpression)
424+ . hmap (K . renderAliased renderExpression)
420
425
421select
426select
422 :: Selection params schema columns
427 :: Selection params schema columns
@@ -436,9 +441,9 @@ INSERT statements
436-----------------------------------------}
441-----------------------------------------}
437
442
438insertInto
443insertInto
439− :: HasTable table schema columns
444+ :: (SListI columns, HasTable table schema columns)
440 => Alias table
445 => Alias table
441− -> Rec (Aliased (Expression params '[])) columns
446+ -> NP (Aliased (Expression params '[])) columns
442 -> Statement params '[] schema schema
447 -> Statement params '[] schema schema
443insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
448insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
444 <> fromString (symbolVal' table)
449 <> fromString (symbolVal' table)
@@ -447,11 +452,11 @@ insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
447 <> ByteString.intercalate ", " values
452 <> ByteString.intercalate ", " values
448 <> ");"
453 <> ");"
449 where
454 where
450− aliases = recordToList $ rmap
455+ aliases = hcollapse $ hmap
451− (\ (_ `As` Alias name) -> Const (fromString (symbolVal' name)))
456+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
452 expressions
457 expressions
453− values = recordToList $ rmap
458+ values = hcollapse $ hmap
454− (\ (expression `As` _) -> Const (renderExpression expression))
459+ (\ (expression `As` _) -> K (renderExpression expression))
455 expressions
460 expressions
456
461
457{-----------------------------------------
462{-----------------------------------------
@@ -486,16 +491,16 @@ serial :: TypeExpression ('Optional ('NotNull 'PGInt4))
486serial = UnsafeTypeExpression "serial"
491serial = UnsafeTypeExpression "serial"
487
492
488createTable
493createTable
489− :: KnownSymbol table
494+ :: (KnownSymbol table, SListI columns)
490 => Alias table
495 => Alias table
491− -> Rec (Aliased TypeExpression) columns
496+ -> NP (Aliased TypeExpression) columns
492 -> Statement '[] '[] schema ((table ::: columns) ': schema)
497 -> Statement '[] '[] schema ((table ::: columns) ': schema)
493createTable (Alias table) columns = UnsafeStatement $ mconcat
498createTable (Alias table) columns = UnsafeStatement $ mconcat
494 [ "CREATE TABLE "
499 [ "CREATE TABLE "
495 , fromString $ symbolVal' table
500 , fromString $ symbolVal' table
496 , " ("
501 , " ("
497− , ByteString.intercalate ", " . recordToList $
502+ , ByteString.intercalate ", " . hcollapse $
498− rmap (Const . renderColumn) columns
503+ hmap (K . renderColumn) columns
499 , ");"
504 , ");"
500 ]
505 ]
501 where
506 where
@@ -516,40 +521,40 @@ instance {-# OVERLAPPING #-}
516 (KnownSymbol table, table ~ table')
521 (KnownSymbol table, table ~ table')
517 => DropTable table ((table' ::: columns) ': schema) schema
522 => DropTable table ((table' ::: columns) ': schema) schema
518instance {-# OVERLAPPABLE #-}
523instance {-# OVERLAPPABLE #-}
519− (KnownSymbol table, DropTable table schema0 schema1)
524+ DropTable table schema0 schema1
520− => DropTable table (tabCols ': schema0) (tabCols ': schema1)
525+ => DropTable table (table' ': schema0) (table' ': schema1)
521
526
522{-----------------------------------------
527{-----------------------------------------
523UPDATE statements
528UPDATE statements
524-----------------------------------------}
529-----------------------------------------}
525
530
526−set :: g x -> (Maybe `Compose` g) x
531+set :: g x -> (Maybe :.: g) x
527−set = Compose . Just
532+set = Comp . Just
528
533
529−same :: (Maybe `Compose` g) x
534+same :: (Maybe :.: g) x
530−same = Compose Nothing
535+same = Comp Nothing
531
536
532update
537update
533− :: HasTable table schema columns
538+ :: (HasTable table schema columns, SListI columns)
534 => Alias table
539 => Alias table
535− -> Rec (Aliased (Maybe `Compose` Expression params '[table ::: columns])) columns
540+ -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns
536 -> Expression params '[table ::: columns] ('Required ('NotNull 'PGBool))
541 -> Expression params '[table ::: columns] ('Required ('NotNull 'PGBool))
537 -> Statement params '[] schema schema
542 -> Statement params '[] schema schema
538update (Alias table) columns where' = UnsafeStatement $ mconcat
543update (Alias table) columns where' = UnsafeStatement $ mconcat
539 [ "UPDATE "
544 [ "UPDATE "
540 , fromString $ symbolVal' table
545 , fromString $ symbolVal' table
541 , " SET "
546 , " SET "
542− , ByteString.intercalate ", " . catMaybes . recordToList $
547+ , ByteString.intercalate ", " . catMaybes . hcollapse $
543− rmap (Const . renderSet) columns
548+ hmap (K . renderSet) columns
544 , " WHERE ", renderExpression where'
549 , " WHERE ", renderExpression where'
545 ] where
550 ] where
546 renderSet
551 renderSet
547− :: Aliased (Maybe `Compose` Expression params tables) column
552+ :: Aliased (Maybe :.: Expression params tables) column
548 -> Maybe ByteString
553 -> Maybe ByteString
549 renderSet = \case
554 renderSet = \case
550− Compose (Just expression) `As` Alias column -> Just $ mconcat
555+ Comp (Just expression) `As` Alias column -> Just $ mconcat
551 [ fromString $ symbolVal' column
556 [ fromString $ symbolVal' column
552 , " = "
557 , " = "
553 , renderExpression expression
558 , renderExpression expression
554 ]
559 ]
555− Compose Nothing `As` _ -> Nothing
560+ Comp Nothing `As` _ -> Nothing
squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+13−13
@@ -10,7 +10,7 @@ module Squeel.PostgreSQL.StatementSpec where
10
10
11import Data.Boolean
11import Data.Boolean
12import Data.Function
12import Data.Function
13−import Data.Vinyl
13+import Generics.SOP hiding (from)
14import Test.Hspec
14import Test.Hspec
15
15
16import Squeel.PostgreSQL.Statement
16import Squeel.PostgreSQL.Statement
@@ -24,7 +24,7 @@ spec = do
24 let
24 let
25 statement :: Statement '[] SumAndCol1 Tables Tables
25 statement :: Statement '[] SumAndCol1 Tables Tables
26 statement = select $
26 statement = select $
27− ((#col1 + #col2) `As` #sum :& #col1 :& RNil)
27+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
28 `from` (#table1 & where_ true)
28 `from` (#table1 & where_ true)
29 statement `shouldRenderAs`
29 statement `shouldRenderAs`
30 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE TRUE;"
30 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE TRUE;"
@@ -32,13 +32,13 @@ spec = do
32 let
32 let
33 statement :: Statement '[] SumAndCol1 Tables Tables
33 statement :: Statement '[] SumAndCol1 Tables Tables
34 statement = select $
34 statement = select $
35− ((#col1 + #col2) `As` #sum :& #col1 :& RNil)
35+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
36 `from` (#table1 & where_ true & where_ false)
36 `from` (#table1 & where_ true & where_ false)
37 statement `shouldRenderAs`
37 statement `shouldRenderAs`
38 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE (TRUE AND FALSE);"
38 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE (TRUE AND FALSE);"
39 it "performs sub SELECTs" $ do
39 it "performs sub SELECTs" $ do
40 let
40 let
41− selection = ((#col1 + #col2) `As` #sum :& #col1 :& RNil) `from` #table1
41+ selection = ((#col1 + #col2) `As` #sum :* #col1 :* Nil) `from` #table1
42 statement :: Statement '[] SumAndCol1 Tables Tables
42 statement :: Statement '[] SumAndCol1 Tables Tables
43 statement = select $ starFrom (subselect (selection `As` #sub))
43 statement = select $ starFrom (subselect (selection `As` #sub))
44 statement `shouldRenderAs`
44 statement `shouldRenderAs`
@@ -72,22 +72,22 @@ spec = do
72 it "correctly render simple INSERTs" $ do
72 it "correctly render simple INSERTs" $ do
73 let
73 let
74 statement :: Statement '[] '[] Tables Tables
74 statement :: Statement '[] '[] Tables Tables
75− statement = insertInto #table1 $ 2 `As` #col1 :& 4 `As` #col2 :& RNil
75+ statement = insertInto #table1 $ 2 `As` #col1 :* 4 `As` #col2 :* Nil
76 statement `shouldRenderAs`
76 statement `shouldRenderAs`
77 "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
77 "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
78 it "should be safe against SQL injection in literal text" $ do
78 it "should be safe against SQL injection in literal text" $ do
79 let
79 let
80 statement :: Statement '[] '[] StudentsTable StudentsTable
80 statement :: Statement '[] '[] StudentsTable StudentsTable
81 statement = insertInto #students $
81 statement = insertInto #students $
82− "Robert'); DROP TABLE students;" `As` #name :& RNil
82+ "Robert'); DROP TABLE students;" `As` #name :* Nil
83 statement `shouldRenderAs`
83 statement `shouldRenderAs`
84 "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
84 "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
85 describe "JOINs" $ do
85 describe "JOINs" $ do
86 let
86 let
87 vals =
87 vals =
88 #orders &. #orderVal `As` #orderVal
88 #orders &. #orderVal `As` #orderVal
89− :& #customers &. #customerVal `As` #customerVal
89+ :* #customers &. #customerVal `As` #customerVal
90− :& #shippers &. #shipperVal `As` #shipperVal :& RNil
90+ :* #shippers &. #shipperVal `As` #shipperVal :* Nil
91 it "should render CROSS JOINs" $ do
91 it "should render CROSS JOINs" $ do
92 let
92 let
93 statement :: Statement '[] ValueColumns JoinTables JoinTables
93 statement :: Statement '[] ValueColumns JoinTables JoinTables
@@ -135,15 +135,15 @@ spec = do
135 it "should render CREATE TABLE statements" $ do
135 it "should render CREATE TABLE statements" $ do
136 createTable #table1
136 createTable #table1
137 ( (int4 & notNull) `As` #col1
137 ( (int4 & notNull) `As` #col1
138− :& (int4 & notNull) `As` #col2
138+ :* (int4 & notNull) `As` #col2
139− :& RNil)
139+ :* Nil)
140 `shouldRenderAs`
140 `shouldRenderAs`
141 "CREATE TABLE table1 (col1 int4 NOT NULL, col2 int4 NOT NULL);"
141 "CREATE TABLE table1 (col1 int4 NOT NULL, col2 int4 NOT NULL);"
142 createTable #table2
142 createTable #table2
143 ( serial `As` #col1
143 ( serial `As` #col1
144− :& text `As` #col2
144+ :* text `As` #col2
145− :& (int8 & notNull & default_ 8) `As` #col3
145+ :* (int8 & notNull & default_ 8) `As` #col3
146− :& RNil)
146+ :* Nil)
147 `shouldRenderAs`
147 `shouldRenderAs`
148 "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8);"
148 "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8);"
149 it "should render DROP TABLE statements" $ do
149 it "should render DROP TABLE statements" $ do