git.iko.soy/squeal
on dev help sign in
Merge pull request #23 from echatav/generics

generics-sop

commit49cbdefe9f977306d3b5ae4c27a252ccd6c66358 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 3 Jul 2017, 11:38 (9 years ago) parentf707a3300a665f
6 files changed+253−200
compare with dev
unifiedsplit
squeel-postgresql/exe/Example.hs+28−12 squeel-postgresql/squeel-postgresql.cabal+6−3 squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+115−117 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+56−25 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+35−30 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+13−13
squeel-postgresql/exe/Example.hs+28−12
@@ -3,6 +3,7 @@
33 , MagicHash
44 , OverloadedLabels
55 , OverloadedStrings
6+ , ScopedTypeVariables
67 , TypeOperators
78#-}
89
@@ -10,10 +11,12 @@ module Main (main) where
1011
1112import Control.Category ((>>>))
1213import Control.Monad.Base
14+import Control.Monad.Except
15+import Control.Monad.Trans.Maybe
1316import Data.Function ((&))
1417import Data.Int
1518import Data.Monoid
16−import Data.Vinyl
19+import Generics.SOP
1720import Squeel.PostgreSQL
1821
1922import qualified Data.ByteString.Char8 as Char8
@@ -29,29 +32,42 @@ main = do
2932 connection1 <- flip execPQ connection0 $ pqExec $
3033 createTable #students
3134 ( (text & notNull) `As` #name
32− :& RNil )
35+ :* Nil )
3336 >>>
3437 createTable #table1
3538 ( (int4 & notNull) `As` #col1
36− :& (int4 & notNull) `As` #col2
37− :& RNil )
39+ :* (int4 & notNull) `As` #col2
40+ :* Nil )
3841 connection2 <- flip execPQ connection1 $ do
3942 _insertTable1Result <- pqExec $
40− insertInto #table1 ( 1 `As` #col1 :& 2 `As` #col2 :& RNil )
43+ insertInto #table1 ( 1 `As` #col1 :* 2 `As` #col2 :* Nil )
4144 >>>
42− insertInto #table1 ( 3 `As` #col1 :& 4 `As` #col2 :& RNil )
43− Just selectTable1Result <- flip pqExecParams RNil $
45+ insertInto #table1 ( 3 `As` #col1 :* 4 `As` #col2 :* Nil )
46+ Just selectTable1Result <- flip pqExecParams Nil $
4447 (select $ starFrom #table1 :: Statement '[] Columns Tables Tables)
45− Just (Right value00) <- getvalue selectTable1Result (RowNumber 0) colNum0
46− Just (Right value01) <- getvalue selectTable1Result (RowNumber 0) colNum1
47− Just (Right value10) <- getvalue selectTable1Result (RowNumber 1) colNum0
48− Just (Right value11) <- getvalue selectTable1Result (RowNumber 1) colNum1
48+ Just (Right value00) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
49+ getValue (RowNumber 0) colNum0
50+ Just (Right value01) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
51+ getValue (RowNumber 0) colNum1
52+ Just (Right value10) <- runMaybeT . runExceptT . flip runValue selectTable1Result $
53+ getValue (RowNumber 1) colNum0
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)
4960 liftBase $ do
5061 print (value00 :: Int32)
5162 print (value01 :: Int32)
5263 print (value10 :: Int32)
5364 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
5571
5672type Columns =
5773 '[ "col1" ::: 'Required ('NotNull 'PGInt4)
squeel-postgresql/squeel-postgresql.cabal+6−3
@@ -25,6 +25,7 @@ library
2525 , base
2626 , Boolean
2727 , bytestring
28+ , generics-sop
2829 , lifted-base
2930 , monad-control
3031 , mtl
@@ -33,9 +34,9 @@ library
3334 , scientific
3435 , text
3536 , time
37+ , transformers
3638 , transformers-base
3739 , uuid
38− , vinyl
3940
4041test-suite squeel-postgresql-test
4142 default-language: Haskell2010
@@ -49,9 +50,9 @@ test-suite squeel-postgresql-test
4950 build-depends:
5051 base
5152 , Boolean
53+ , generics-sop
5254 , hspec
5355 , squeel-postgresql
54− , vinyl
5556
5657executable squeel-postgresql-example
5758 default-language: Haskell2010
@@ -61,9 +62,11 @@ executable squeel-postgresql-example
6162 build-depends:
6263 base
6364 , bytestring
65+ , generics-sop
66+ , mtl
6467 , squeel-postgresql
68+ , transformers
6569 , transformers-base
66− , vinyl
6770
6871source-repository head
6972 type: git
squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+115−117
@@ -1,7 +1,9 @@
11{-# LANGUAGE
22 DataKinds
3+ , FlexibleContexts
34 , FlexibleInstances
45 , GADTs
6+ , LambdaCase
57 , MagicHash
68 , MultiParamTypeClasses
79 , PolyKinds
@@ -11,137 +13,133 @@
1113
1214module Squeel.PostgreSQL.Binary where
1315
14−import Control.Arrow (left)
15−import Data.Aeson (FromJSON, ToJSON, eitherDecodeStrict, encode)
1616import Data.ByteString (ByteString)
1717import Data.Int (Int16,Int32,Int64)
18−import Data.Vinyl
19−import Data.Vinyl.Functor
20−import PostgreSQL.Binary.Decoding (Value)
21−import PostgreSQL.Binary.Encoding (Encoding)
18+import Generics.SOP
2219import Data.Scientific (Scientific)
2320import Data.Text (Text)
2421import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
2522import Data.UUID (UUID)
26−import GHC.Exts
2723
28−import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
29−import qualified Data.Text as Text (pack)
24+import qualified Data.Aeson as Aeson
25+import qualified Data.ByteString.Lazy as Lazy (ByteString)
3026import qualified Data.Text.Lazy as Lazy (Text)
3127import qualified PostgreSQL.Binary.Decoding as Decoder
3228import qualified PostgreSQL.Binary.Encoding as Encoder
3329
3430import Squeel.PostgreSQL.Schema
3531
36−decodeValue :: FromValue pg x => Proxy# pg -> ByteString -> Either Text x
37−decodeValue p = Decoder.valueParser $ fromValue p
32+decodeValue :: HasDecoding pg x => proxy pg -> ByteString -> Either Text x
33+decodeValue p = Decoder.valueParser $ decoding p
3834
39−class FromValue pg x where
40− fromValue :: Proxy# pg -> Value x
41−instance FromValue 'PGInt2 Int16 where
42− fromValue _ = Decoder.int
43−instance FromValue 'PGInt4 Int32 where
44− fromValue _ = Decoder.int
45−instance FromValue 'PGInt8 Int64 where
46− fromValue _ = Decoder.int
47−instance FromValue 'PGFloat4 Float where
48− fromValue _ = Decoder.float4
49−instance FromValue 'PGFloat8 Double where
50− fromValue _ = Decoder.float8
51−instance FromValue 'PGBool Bool where
52− fromValue _ = Decoder.bool
53−instance FromValue 'PGBytea ByteString where
54− fromValue _ = Decoder.bytea_strict
55−instance FromValue 'PGBytea Lazy.ByteString where
56− fromValue _ = Decoder.bytea_lazy
57−instance FromValue 'PGText Text where
58− fromValue _ = Decoder.text_strict
59−instance FromValue 'PGText Lazy.Text where
60− fromValue _ = Decoder.text_lazy
61−instance FromValue ('PGChar 1) Char where
62− fromValue _ = Decoder.char
63−instance FromValue 'PGNumeric Scientific where
64− fromValue _ = Decoder.numeric
65−instance FromValue 'PGUuid UUID where
66− fromValue _ = Decoder.uuid
67−instance FromJSON x => FromValue 'PGJson x where
68− fromValue _ = Decoder.json_bytes (left Text.pack . eitherDecodeStrict)
69−instance FromJSON x => FromValue 'PGJsonb x where
70− fromValue _ = Decoder.jsonb_bytes (left Text.pack . eitherDecodeStrict)
71−instance FromValue 'PGDate Day where
72− fromValue _ = Decoder.date
73−instance FromValue 'PGTime TimeOfDay where
74− fromValue _ = Decoder.time_int
75−instance FromValue 'PGTimeTZ (TimeOfDay, TimeZone) where
76− fromValue _ = Decoder.timetz_int
77−instance FromValue 'PGTimestamp LocalTime where
78− fromValue _ = Decoder.timestamp_int
79−instance FromValue 'PGTimestampTZ UTCTime where
80− fromValue _ = Decoder.timestamptz_int
81−instance FromValue 'PGInterval DiffTime where
82− fromValue _ = Decoder.interval_int
83−instance FromValue pg ty => FromValue (column ::: 'Required ('NotNull pg)) ty where
84− fromValue _ = fromValue (proxy# :: Proxy# pg)
35+class HasDecoding pg x where
36+ decoding :: proxy pg -> Decoder.Value x
37+instance HasDecoding (column ::: 'Required ('NotNull 'PGInt2)) Int16 where
38+ decoding _ = Decoder.int
39+instance HasDecoding (column ::: 'Required ('NotNull 'PGInt4)) Int32 where
40+ decoding _ = Decoder.int
41+instance HasDecoding (column ::: 'Required ('NotNull 'PGInt8)) Int64 where
42+ decoding _ = Decoder.int
43+instance HasDecoding (column ::: 'Required ('NotNull 'PGFloat4)) Float where
44+ decoding _ = Decoder.float4
45+instance HasDecoding (column ::: 'Required ('NotNull 'PGFloat8)) Double where
46+ decoding _ = Decoder.float8
47+instance HasDecoding (column ::: 'Required ('NotNull 'PGBool)) Bool where
48+ decoding _ = Decoder.bool
49+instance HasDecoding (column ::: 'Required ('NotNull 'PGBytea)) ByteString where
50+ decoding _ = Decoder.bytea_strict
51+instance HasDecoding (column ::: 'Required ('NotNull 'PGBytea)) Lazy.ByteString where
52+ decoding _ = Decoder.bytea_lazy
53+instance HasDecoding (column ::: 'Required ('NotNull 'PGText)) Text where
54+ decoding _ = Decoder.text_strict
55+instance HasDecoding (column ::: 'Required ('NotNull 'PGText)) Lazy.Text where
56+ decoding _ = Decoder.text_lazy
57+instance HasDecoding (column ::: 'Required ('NotNull ('PGChar 1))) Char where
58+ decoding _ = Decoder.char
59+instance HasDecoding (column ::: 'Required ('NotNull 'PGNumeric)) Scientific where
60+ decoding _ = Decoder.numeric
61+instance HasDecoding (column ::: 'Required ('NotNull 'PGUuid)) UUID where
62+ decoding _ = Decoder.uuid
63+instance HasDecoding (column ::: 'Required ('NotNull 'PGJson)) Aeson.Value where
64+ decoding _ = Decoder.json_ast
65+instance HasDecoding (column ::: 'Required ('NotNull 'PGJsonb)) Aeson.Value where
66+ decoding _ = Decoder.jsonb_ast
67+instance HasDecoding (column ::: 'Required ('NotNull 'PGDate)) Day where
68+ decoding _ = Decoder.date
69+instance HasDecoding (column ::: 'Required ('NotNull 'PGTime)) TimeOfDay where
70+ decoding _ = Decoder.time_int
71+instance HasDecoding (column ::: 'Required ('NotNull 'PGTimeTZ)) (TimeOfDay, TimeZone) where
72+ decoding _ = Decoder.timetz_int
73+instance HasDecoding (column ::: 'Required ('NotNull 'PGTimestamp)) LocalTime where
74+ decoding _ = Decoder.timestamp_int
75+instance HasDecoding (column ::: 'Required ('NotNull 'PGTimestampTZ)) UTCTime where
76+ decoding _ = Decoder.timestamptz_int
77+instance HasDecoding (column ::: 'Required ('NotNull 'PGInterval)) DiffTime where
78+ decoding _ = Decoder.interval_int
8579
86−class FromValues pgs xs where
87− decodeValues :: Proxy# pgs -> Rec (Const ByteString) xs -> Rec (Either Text) xs
88−instance FromValues '[] '[] where decodeValues _ _ = RNil
89−instance (FromValue pg x, FromValues pgs xs)
90− => FromValues (pg ': pgs) (x ': xs) where
91− decodeValues _ (Const result :& results) =
92− decodeValue (proxy# :: Proxy# pg) result
93− :& decodeValues (proxy# :: Proxy# pgs) results
80+decodings
81+ :: AllZip HasDecoding pgs xs
82+ => proxy pgs
83+ -> NP (K ByteString) xs -> Either Text (NP I xs)
84+decodings _ Nil = return Nil
85+decodings (_ :: proxy pgs) (K bytestring :* bytestrings) =
86+ case (hpure Proxy :: NP Proxy pgs) of
87+ proxy :* proxies -> (:*)
88+ <$> (I <$> Decoder.valueParser (decoding proxy) bytestring)
89+ <*> decodings proxies bytestrings
9490
95−class ToValue x pg where
96− toValue :: Proxy# pg -> x -> Encoding
97−instance ToValue Int16 'PGInt2 where
98− toValue _ = Encoder.int2_int16
99−instance ToValue Int32 'PGInt4 where
100− toValue _ = Encoder.int4_int32
101−instance ToValue Int64 'PGInt8 where
102− toValue _ = Encoder.int8_int64
103−instance ToValue Float 'PGFloat4 where
104− toValue _ = Encoder.float4
105−instance ToValue Double 'PGFloat8 where
106− toValue _ = Encoder.float8
107−instance ToValue Bool 'PGBool where
108− toValue _ = Encoder.bool
109−instance ToValue ByteString 'PGBytea where
110− toValue _ = Encoder.bytea_strict
111−instance ToValue Lazy.ByteString 'PGBytea where
112− toValue _ = Encoder.bytea_lazy
113−instance ToValue Text 'PGText where
114− toValue _ = Encoder.text_strict
115−instance ToValue Lazy.Text 'PGText where
116− toValue _ = Encoder.text_lazy
117−instance ToValue Char ('PGChar 1) where
118− toValue _ = Encoder.char_utf8
119−instance ToValue Scientific 'PGNumeric where
120− toValue _ = Encoder.numeric
121−instance ToValue UUID 'PGUuid where
122− toValue _ = Encoder.uuid
123−instance ToJSON x => ToValue x 'PGJson where
124− toValue _ = Encoder.json_bytes . Lazy.toStrict . encode
125−instance ToJSON x => ToValue x 'PGJsonb where
126− toValue _ = Encoder.jsonb_bytes . Lazy.toStrict . encode
127−instance ToValue Day 'PGDate where
128− toValue _ = Encoder.date
129−instance ToValue TimeOfDay 'PGTime where
130− toValue _ = Encoder.time_int
131−instance ToValue (TimeOfDay, TimeZone) 'PGTimeTZ where
132− toValue _ = Encoder.timetz_int
133−instance ToValue LocalTime 'PGTimestamp where
134− toValue _ = Encoder.timestamp_int
135−instance ToValue UTCTime 'PGTimestampTZ where
136− toValue _ = Encoder.timestamptz_int
137−instance ToValue DiffTime 'PGInterval where
138− toValue _ = Encoder.interval_int
91+class HasEncoding pg x where
92+ encoding :: proxy pg -> x -> Encoder.Encoding
93+instance HasEncoding ('Required ('NotNull 'PGInt2)) Int16 where
94+ encoding _ = Encoder.int2_int16
95+instance HasEncoding ('Required ('NotNull 'PGInt4)) Int32 where
96+ encoding _ = Encoder.int4_int32
97+instance HasEncoding ('Required ('NotNull 'PGInt8)) Int64 where
98+ encoding _ = Encoder.int8_int64
99+instance HasEncoding ('Required ('NotNull 'PGFloat4)) Float where
100+ encoding _ = Encoder.float4
101+instance HasEncoding ('Required ('NotNull 'PGFloat8)) Double where
102+ encoding _ = Encoder.float8
103+instance HasEncoding ('Required ('NotNull 'PGBool)) Bool where
104+ encoding _ = Encoder.bool
105+instance HasEncoding ('Required ('NotNull 'PGBytea)) ByteString where
106+ encoding _ = Encoder.bytea_strict
107+instance HasEncoding ('Required ('NotNull 'PGBytea)) Lazy.ByteString where
108+ encoding _ = Encoder.bytea_lazy
109+instance HasEncoding ('Required ('NotNull 'PGText)) Text where
110+ encoding _ = Encoder.text_strict
111+instance HasEncoding ('Required ('NotNull 'PGText)) Lazy.Text where
112+ encoding _ = Encoder.text_lazy
113+instance HasEncoding ('Required ('NotNull ('PGChar 1))) Char where
114+ encoding _ = Encoder.char_utf8
115+instance HasEncoding ('Required ('NotNull 'PGNumeric)) Scientific where
116+ encoding _ = Encoder.numeric
117+instance HasEncoding ('Required ('NotNull 'PGUuid)) UUID where
118+ encoding _ = Encoder.uuid
119+instance HasEncoding ('Required ('NotNull 'PGJson)) Aeson.Value where
120+ encoding _ = Encoder.json_ast
121+instance HasEncoding ('Required ('NotNull 'PGJsonb)) Aeson.Value where
122+ encoding _ = Encoder.jsonb_ast
123+instance HasEncoding ('Required ('NotNull 'PGDate)) Day where
124+ encoding _ = Encoder.date
125+instance HasEncoding ('Required ('NotNull 'PGTime)) TimeOfDay where
126+ encoding _ = Encoder.time_int
127+instance HasEncoding ('Required ('NotNull 'PGTimeTZ)) (TimeOfDay, TimeZone) where
128+ encoding _ = Encoder.timetz_int
129+instance HasEncoding ('Required ('NotNull 'PGTimestamp)) LocalTime where
130+ encoding _ = Encoder.timestamp_int
131+instance HasEncoding ('Required ('NotNull 'PGTimestampTZ)) UTCTime where
132+ encoding _ = Encoder.timestamptz_int
133+instance HasEncoding ('Required ('NotNull 'PGInterval)) DiffTime where
134+ encoding _ = Encoder.interval_int
139135
140−class ToValues xs pgs where
141− toValues :: Proxy# pgs -> Rec Identity xs -> [ByteString]
142−instance ToValues '[] '[] where toValues _ _ = []
143−instance (ToValue x pg, ToValues xs pgs)
144− => ToValues (x ': xs) (pg ': pgs) where
145− toValues _ (Identity x :& xs)
146− = Encoder.encodingBytes ((toValue (proxy# :: Proxy# pg)) x)
147− : toValues (proxy# :: Proxy# pgs) xs
136+encodings
137+ :: AllZip HasEncoding pgs xs
138+ => proxy pgs
139+ -> NP I xs
140+ -> [ByteString]
141+encodings _ Nil = []
142+encodings (_ :: proxy pgs) (I x :* xs) =
143+ case (hpure Proxy :: NP Proxy pgs) of
144+ proxy :* proxies -> Encoder.encodingBytes (encoding proxy x)
145+ : encodings proxies xs
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+56−25
@@ -10,6 +10,7 @@
1010 , MultiParamTypeClasses
1111 , RankNTypes
1212 , ScopedTypeVariables
13+ , TypeApplications
1314 , TypeFamilies
1415 , TypeOperators
1516 , UndecidableInstances
@@ -19,13 +20,15 @@ module Squeel.PostgreSQL.PQ where
1920
2021import Control.Exception.Lifted
2122import Control.Monad.Base
22−import Control.Monad.Trans
23+import Control.Monad.Except
24+import Control.Monad.Trans.Maybe
2325import Control.Monad.Trans.Control
2426import Data.ByteString (ByteString)
27+import Data.Maybe
28+import Data.Proxy (Proxy)
2529import Data.Text (Text)
26−import Data.Vinyl
27−import Data.Vinyl.Functor
28−import GHC.Exts
30+import Generics.SOP
31+import GHC.Exts hiding (fromList)
2932import GHC.TypeLits
3033
3134import qualified Database.PostgreSQL.LibPQ as LibPQ
@@ -70,9 +73,9 @@ class MonadPQ pq where
7073 -> pq db0 db1 io (Maybe (Result '[]))
7174
7275 pqExecParams
73− :: (MonadBase IO io, ToOids ps, ToValues xs ps)
76+ :: (MonadBase IO io, ToOids ps, AllZip HasEncoding ps xs, All Top ps)
7477 => Statement ps ys db0 db1
75− -> Rec Identity xs
78+ -> NP I xs
7679 -> pq db0 db1 io (Maybe (Result ys))
7780
7881 pqPrepare
@@ -82,9 +85,9 @@ class MonadPQ pq where
8285 -> pq db0 db1 io (Maybe (Result []), PreparedStatement ps xs db0 db1)
8386
8487 pqExecPrepared
85− :: (MonadBase IO io, ToValues xs ps)
88+ :: (MonadBase IO io, AllZip HasEncoding ps xs, All Top ps)
8689 => PreparedStatement ps ys db0 db1
87− -> Rec Identity xs
90+ -> NP I xs
8891 -> pq db0 db1 io (Maybe (Result ys))
8992
9093instance MonadPQ PQ where
@@ -105,12 +108,11 @@ instance MonadPQ PQ where
105108 pqExecParams (UnsafeStatement q :: Statement ps ys db0 db1) params =
106109 PQ $ \ (Connection conn) -> do
107110 let
111+ paramValues = encodings (Proxy :: Proxy ps) params
112+ oids = toOids (proxy# :: Proxy# ps)
108113 params' =
109114 [ Just (oid, param', LibPQ.Binary)
110− | (oid, param') <-
111− zip
112− (toOids (proxy# :: Proxy# ps))
113− (toValues (proxy# :: Proxy# ps) params)
115+ | (oid, param') <- zip oids paramValues
114116 ]
115117 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
116118 return (Result <$> result, Connection conn)
@@ -127,10 +129,8 @@ instance MonadPQ PQ where
127129 pqExecPrepared (q :: PreparedStatement ps ys db0 db1) params =
128130 PQ $ \ (Connection conn) -> do
129131 let
130− params' =
131− [ Just (param', LibPQ.Binary)
132− | param' <- toValues (proxy# :: Proxy# ps) params
133− ]
132+ paramValues = encodings (Proxy :: Proxy ps) params
133+ params' = [ Just (param', LibPQ.Binary) | param' <- paramValues ]
134134 result <- liftBase $
135135 LibPQ.execPrepared conn (renderPreparedStatement q) params' LibPQ.Binary
136136 return (Result <$> result, Connection conn)
@@ -203,12 +203,43 @@ colNum3 = colNum (proxy# :: Proxy# 3)
203203colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4
204204colNum4 = colNum (proxy# :: Proxy# 4)
205205
206−getvalue
207− :: (FromValue x y, MonadBase IO io)
208− => Result xs
209− -> RowNumber
210− -> ColumnNumber xs x
211− -> io (Maybe (Either Text y))
212−getvalue (Result result) (RowNumber r) (ColumnNumber c :: ColumnNumber xs x) =
213− liftBase $ fmap (fmap (decodeValue (proxy# :: Proxy# x)))
214− (LibPQ.getvalue' result r c)
206+newtype Value pgs m x = Value { runValue :: Result pgs -> m x }
207+ deriving (Functor)
208+instance Applicative m => Applicative (Value pgs m) where
209+ pure x = Value $ \ _result -> pure x
210+ mf <*> mx = Value $ \ result -> runValue mf result <*> runValue mx result
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
226+getValue (RowNumber r) (ColumnNumber c :: ColumnNumber pgs pg) =
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
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)
2020import Data.Maybe
2121import Data.Monoid
2222import Data.String
23−import Data.Vinyl
24−import Data.Vinyl.Functor
23+import Generics.SOP
2524import GHC.Exts
2625import GHC.OverloadedLabels
2726import GHC.TypeLits
@@ -84,6 +83,11 @@ Alias table &. Alias column = UnsafeExpression $
8483def :: Expression params '[] ('Optional (nullity ty))
8584def = UnsafeExpression "DEFAULT"
8685
86+notDef
87+ :: Expression params '[] ('Required (nullity ty))
88+ -> Expression params '[] ('Optional (nullity ty))
89+notDef = UnsafeExpression . renderExpression
90+
8791null :: Expression params tables (optionality ('Null ty))
8892null = UnsafeExpression "NULL"
8993
@@ -117,8 +121,8 @@ unsafeFunction
117121 :: ByteString
118122 -> Expression params tables xty
119123 -> Expression params tables yty
120−unsafeFunction fn x = UnsafeExpression $ mconcat
121− [fn, "(", renderExpression x, ")"]
124+unsafeFunction fun x = UnsafeExpression $ mconcat
125+ [fun, "(", renderExpression x, ")"]
122126
123127instance PGNum ty => Num (Expression params tables ('Required (nullity ty))) where
124128 (+) = unsafeBinaryOp "+"
@@ -407,7 +411,8 @@ Alias tab `dotStarFrom` tabs = UnsafeSelection $
407411 fromString (symbolVal' tab) <> ".* FROM " <> renderFrom tabs
408412
409413from
410− :: Rec (Aliased (Expression params tables)) columns
414+ :: SListI columns
415+ => NP (Aliased (Expression params tables)) columns
411416 -> From params schema tables
412417 -> Selection params schema columns
413418list `from` tabs = UnsafeSelection $
@@ -415,8 +420,8 @@ list `from` tabs = UnsafeSelection $
415420 where
416421 renderList
417422 = ByteString.intercalate ", "
418− . recordToList
419− . rmap (Const . renderAliased renderExpression)
423+ . hcollapse
424+ . hmap (K . renderAliased renderExpression)
420425
421426select
422427 :: Selection params schema columns
@@ -436,9 +441,9 @@ INSERT statements
436441-----------------------------------------}
437442
438443insertInto
439− :: HasTable table schema columns
444+ :: (SListI columns, HasTable table schema columns)
440445 => Alias table
441− -> Rec (Aliased (Expression params '[])) columns
446+ -> NP (Aliased (Expression params '[])) columns
442447 -> Statement params '[] schema schema
443448insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
444449 <> fromString (symbolVal' table)
@@ -447,11 +452,11 @@ insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
447452 <> ByteString.intercalate ", " values
448453 <> ");"
449454 where
450− aliases = recordToList $ rmap
451− (\ (_ `As` Alias name) -> Const (fromString (symbolVal' name)))
455+ aliases = hcollapse $ hmap
456+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
452457 expressions
453− values = recordToList $ rmap
454− (\ (expression `As` _) -> Const (renderExpression expression))
458+ values = hcollapse $ hmap
459+ (\ (expression `As` _) -> K (renderExpression expression))
455460 expressions
456461
457462{-----------------------------------------
@@ -486,16 +491,16 @@ serial :: TypeExpression ('Optional ('NotNull 'PGInt4))
486491serial = UnsafeTypeExpression "serial"
487492
488493createTable
489− :: KnownSymbol table
494+ :: (KnownSymbol table, SListI columns)
490495 => Alias table
491− -> Rec (Aliased TypeExpression) columns
496+ -> NP (Aliased TypeExpression) columns
492497 -> Statement '[] '[] schema ((table ::: columns) ': schema)
493498createTable (Alias table) columns = UnsafeStatement $ mconcat
494499 [ "CREATE TABLE "
495500 , fromString $ symbolVal' table
496501 , " ("
497− , ByteString.intercalate ", " . recordToList $
498− rmap (Const . renderColumn) columns
502+ , ByteString.intercalate ", " . hcollapse $
503+ hmap (K . renderColumn) columns
499504 , ");"
500505 ]
501506 where
@@ -516,40 +521,40 @@ instance {-# OVERLAPPING #-}
516521 (KnownSymbol table, table ~ table')
517522 => DropTable table ((table' ::: columns) ': schema) schema
518523instance {-# OVERLAPPABLE #-}
519− (KnownSymbol table, DropTable table schema0 schema1)
520− => DropTable table (tabCols ': schema0) (tabCols ': schema1)
524+ DropTable table schema0 schema1
525+ => DropTable table (table' ': schema0) (table' ': schema1)
521526
522527{-----------------------------------------
523528UPDATE statements
524529-----------------------------------------}
525530
526−set :: g x -> (Maybe `Compose` g) x
527−set = Compose . Just
531+set :: g x -> (Maybe :.: g) x
532+set = Comp . Just
528533
529−same :: (Maybe `Compose` g) x
530−same = Compose Nothing
534+same :: (Maybe :.: g) x
535+same = Comp Nothing
531536
532537update
533− :: HasTable table schema columns
538+ :: (HasTable table schema columns, SListI columns)
534539 => Alias table
535− -> Rec (Aliased (Maybe `Compose` Expression params '[table ::: columns])) columns
540+ -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns
536541 -> Expression params '[table ::: columns] ('Required ('NotNull 'PGBool))
537542 -> Statement params '[] schema schema
538543update (Alias table) columns where' = UnsafeStatement $ mconcat
539544 [ "UPDATE "
540545 , fromString $ symbolVal' table
541546 , " SET "
542− , ByteString.intercalate ", " . catMaybes . recordToList $
543− rmap (Const . renderSet) columns
547+ , ByteString.intercalate ", " . catMaybes . hcollapse $
548+ hmap (K . renderSet) columns
544549 , " WHERE ", renderExpression where'
545550 ] where
546551 renderSet
547− :: Aliased (Maybe `Compose` Expression params tables) column
552+ :: Aliased (Maybe :.: Expression params tables) column
548553 -> Maybe ByteString
549554 renderSet = \case
550− Compose (Just expression) `As` Alias column -> Just $ mconcat
555+ Comp (Just expression) `As` Alias column -> Just $ mconcat
551556 [ fromString $ symbolVal' column
552557 , " = "
553558 , renderExpression expression
554559 ]
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
1010
1111import Data.Boolean
1212import Data.Function
13−import Data.Vinyl
13+import Generics.SOP hiding (from)
1414import Test.Hspec
1515
1616import Squeel.PostgreSQL.Statement
@@ -24,7 +24,7 @@ spec = do
2424 let
2525 statement :: Statement '[] SumAndCol1 Tables Tables
2626 statement = select $
27− ((#col1 + #col2) `As` #sum :& #col1 :& RNil)
27+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
2828 `from` (#table1 & where_ true)
2929 statement `shouldRenderAs`
3030 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE TRUE;"
@@ -32,13 +32,13 @@ spec = do
3232 let
3333 statement :: Statement '[] SumAndCol1 Tables Tables
3434 statement = select $
35− ((#col1 + #col2) `As` #sum :& #col1 :& RNil)
35+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
3636 `from` (#table1 & where_ true & where_ false)
3737 statement `shouldRenderAs`
3838 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE (TRUE AND FALSE);"
3939 it "performs sub SELECTs" $ do
4040 let
41− selection = ((#col1 + #col2) `As` #sum :& #col1 :& RNil) `from` #table1
41+ selection = ((#col1 + #col2) `As` #sum :* #col1 :* Nil) `from` #table1
4242 statement :: Statement '[] SumAndCol1 Tables Tables
4343 statement = select $ starFrom (subselect (selection `As` #sub))
4444 statement `shouldRenderAs`
@@ -72,22 +72,22 @@ spec = do
7272 it "correctly render simple INSERTs" $ do
7373 let
7474 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
7676 statement `shouldRenderAs`
7777 "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
7878 it "should be safe against SQL injection in literal text" $ do
7979 let
8080 statement :: Statement '[] '[] StudentsTable StudentsTable
8181 statement = insertInto #students $
82− "Robert'); DROP TABLE students;" `As` #name :& RNil
82+ "Robert'); DROP TABLE students;" `As` #name :* Nil
8383 statement `shouldRenderAs`
8484 "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
8585 describe "JOINs" $ do
8686 let
8787 vals =
8888 #orders &. #orderVal `As` #orderVal
89− :& #customers &. #customerVal `As` #customerVal
90− :& #shippers &. #shipperVal `As` #shipperVal :& RNil
89+ :* #customers &. #customerVal `As` #customerVal
90+ :* #shippers &. #shipperVal `As` #shipperVal :* Nil
9191 it "should render CROSS JOINs" $ do
9292 let
9393 statement :: Statement '[] ValueColumns JoinTables JoinTables
@@ -135,15 +135,15 @@ spec = do
135135 it "should render CREATE TABLE statements" $ do
136136 createTable #table1
137137 ( (int4 & notNull) `As` #col1
138− :& (int4 & notNull) `As` #col2
139− :& RNil)
138+ :* (int4 & notNull) `As` #col2
139+ :* Nil)
140140 `shouldRenderAs`
141141 "CREATE TABLE table1 (col1 int4 NOT NULL, col2 int4 NOT NULL);"
142142 createTable #table2
143143 ( serial `As` #col1
144− :& text `As` #col2
145− :& (int8 & notNull & default_ 8) `As` #col3
146− :& RNil)
144+ :* text `As` #col2
145+ :* (int8 & notNull & default_ 8) `As` #col3
146+ :* Nil)
147147 `shouldRenderAs`
148148 "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8);"
149149 it "should render DROP TABLE statements" $ do