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

Generics

commit82815526b5269e71eca2992506f638a9a5559a77 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 14 Aug 2017, 12:03 (9 years ago) parent4ffd6a69de9f3e
7 files changed+409−422
compare with dev
unifiedsplit
squeel-postgresql/exe/Example.hs+54−40 squeel-postgresql/squeel-postgresql.cabal+2−1 squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+156−123 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+26−52 squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+42−58 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+100−124 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+29−24
squeel-postgresql/exe/Example.hs+54−40
@@ -1,18 +1,19 @@
11{-# LANGUAGE
22 DataKinds
3+ , DeriveGeneric
4+ , FlexibleInstances
5+ , MultiParamTypeClasses
36 , OverloadedLabels
47 , OverloadedStrings
58 , TypeApplications
69 , TypeOperators
10+ , TypeSynonymInstances
711#-}
812
9−module Main (main) where
13+module Main (main,col1,col2) where
1014
1115import Control.Category ((>>>))
1216import Control.Monad.Base
13−import Control.Monad.Except
14−import Control.Monad.Trans.Maybe
15−import Data.Foldable (for_)
1617import Data.Function ((&))
1718import Data.Int
1819import Data.Monoid
@@ -20,6 +21,20 @@ import Generics.SOP hiding (from)
2021import Squeel.PostgreSQL
2122
2223import qualified Data.ByteString.Char8 as Char8
24+import qualified GHC.Generics as GHC
25+
26+type Schema =
27+ '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGtext)]
28+ , "table1" :::
29+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
30+ , "col2" ::: 'Required ('NotNull 'PGint4)
31+ ]
32+ ]
33+
34+data Table1Row = Table1Row { col1 :: Int32, col2 :: Int32 }
35+ deriving (Show, GHC.Generic)
36+instance Generic Table1Row
37+instance HasDatatypeInfo Table1Row
2338
2439main :: IO ()
2540main = do
@@ -28,46 +43,45 @@ main = do
2843 "host=localhost port=5432 dbname=exampledb"
2944 Char8.putStrLn $ "connecting to " <> connectionString
3045 connection0 <- connectdb connectionString
31− Char8.putStrLn "setting up database"
46+ Char8.putStrLn "setting up schema"
3247 connection1 <- runPQ (connection0 :: Connection '[]) $ pqExec $
33− createTable #students
34− ( (text & notNull) `As` #name
35− :* Nil ) []
48+ createTable #students ((text & notNull) `As` #name :* Nil ) []
3649 >>>
3750 createTable #table1
38− ( (int4 & notNull) `As` #col1
39− :* (int4 & notNull) `As` #col2
40− :* Nil ) []
41− Char8.putStrLn "querying"
42− connection2 <- runPQ (connection1 :: Connection Tables) $ do
43− for_ [I i :* I (i+1) :* Nil | i <- [1::Int32,3..9]] $ pqExecParams
44− ( insertInto #table1
45− (Values (param1 `As` #col1 :* param2 `As` #col2 :* Nil) [])
46− Conflict ReturningNil )
51+ ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil) []
52+ connection2 <- runPQ (connection1 :: Connection Schema) $ do
53+ let
54+ manipulation :: Manipulation Schema
55+ '[ 'Required ('NotNull 'PGint4)
56+ , 'Required ('NotNull 'PGint4)
57+ , 'Required ('NotNull 'PGint4)
58+ , 'Required ('NotNull 'PGint4)
59+ ] '[]
60+ manipulation =
61+ insertInto #table1
62+ ( Values
63+ (param (Proxy @1) `As` #col1 :* param (Proxy @2) `As` #col2 :* Nil)
64+ [param (Proxy @3) `As` #col1 :* param (Proxy @4) `As` #col2 :* Nil]
65+ ) Conflict ReturningNil
66+ liftBase $ Char8.putStrLn "manipulating"
67+ _ <- pqExecParams manipulation (1::Int32,2::Int32,3::Int32,4::Int32)
68+ liftBase $ Char8.putStrLn "querying"
4769 Just result <- pqExecNil . query $
4870 selectStar (from (Table (#table1 `As` #table1)))
49− runMaybeT . runExceptT . flip runValue result $ do
50− value00 <- getValue (RowNumber 0) (columnNumber @0)
51− value01 <- getValue (RowNumber 0) (columnNumber @1)
52− value10 <- getValue (RowNumber 1) (columnNumber @0)
53− value11 <- getValue (RowNumber 1) (columnNumber @1)
54− row0 <- getRow (RowNumber 0)
55− row1 <- getRow (RowNumber 1)
56− liftBase $ do
57− print (value00 :: Int32)
58− print (value01 :: Int32)
59− print (value10 :: Int32)
60− print (value11 :: Int32)
61− print (row0 :: NP I '[Int32,Int32])
62− print (row1 :: NP I '[Int32,Int32])
63− Char8.putStrLn "tearing down database"
64− connection3 <- runPQ (connection2 :: Connection Tables) $ pqExec $
71+ value00 <- getValue (RowNumber 0) (columnNumber @0) result
72+ value01 <- getValue (RowNumber 0) (columnNumber @1) result
73+ value10 <- getValue (RowNumber 1) (columnNumber @0) result
74+ value11 <- getValue (RowNumber 1) (columnNumber @1) result
75+ row0 <- getRow (RowNumber 0) result
76+ row1 <- getRow (RowNumber 1) result
77+ liftBase $ do
78+ print (value00 :: Int32)
79+ print (value01 :: Int32)
80+ print (value10 :: Int32)
81+ print (value11 :: Int32)
82+ print (row0 :: Table1Row)
83+ print (row1 :: Table1Row)
84+ Char8.putStrLn "tearing down schema"
85+ connection3 <- runPQ (connection2 :: Connection Schema) $ pqExec $
6586 dropTable #table1 >>> dropTable #students
6687 finish (connection3 :: Connection '[])
67−
68−type Columns =
69− '[ "col1" ::: 'Required ('NotNull 'PGInt4)
70− , "col2" ::: 'Required ('NotNull 'PGInt4)
71− ]
72−type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]
73−type Tables = '["students" ::: StudentsColumns, "table1" ::: Columns]
squeel-postgresql/squeel-postgresql.cabal+2−1
@@ -19,7 +19,7 @@ library
1919 Squeel.PostgreSQL.Statement
2020 Squeel.PostgreSQL.Schema
2121 default-language: Haskell2010
22− ghc-options: -Wall -Werror
22+ ghc-options: -Wall -Werror -fprint-explicit-kinds
2323 build-depends:
2424 aeson
2525 , base
@@ -28,6 +28,7 @@ library
2828 , lifted-base
2929 , monad-control
3030 , mtl
31+ , network-ip
3132 , postgresql-binary
3233 , postgresql-libpq
3334 , scientific
squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+156−123
@@ -1,145 +1,178 @@
11{-# LANGUAGE
22 DataKinds
3+ , DefaultSignatures
4+ , DeriveFoldable
5+ , DeriveFunctor
6+ , DeriveGeneric
7+ , DeriveTraversable
38 , FlexibleContexts
49 , FlexibleInstances
510 , GADTs
611 , LambdaCase
7− , MagicHash
12+ , KindSignatures
813 , MultiParamTypeClasses
9− , PolyKinds
1014 , ScopedTypeVariables
15+ , TypeApplications
16+ , TypeFamilies
1117 , TypeOperators
18+ , UndecidableInstances
1219#-}
1320
1421module Squeel.PostgreSQL.Binary where
1522
16−import Data.ByteString (ByteString)
17−import Data.Int (Int16,Int32,Int64)
23+import Data.Aeson hiding (Null)
24+import Data.Bits
25+import Data.Int
26+import Data.Scientific
27+import Data.Time
28+import Data.Word
29+import Data.UUID
1830import Generics.SOP
19−import Data.Scientific (Scientific)
20−import Data.Text (Text)
21−import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
22−import Data.UUID (UUID)
31+import Network.IP.Addr
2332
24−import qualified Data.Aeson as Aeson
25−import qualified Data.ByteString.Lazy as Lazy (ByteString)
26−import qualified Data.Text.Lazy as Lazy (Text)
27−import qualified PostgreSQL.Binary.Decoding as Decoder
28−import qualified PostgreSQL.Binary.Encoding as Encoder
33+import qualified Data.ByteString.Lazy as Lazy
34+import qualified Data.ByteString as Strict hiding (unpack)
35+import qualified Data.Text.Lazy as Lazy
36+import qualified Data.Text as Strict
37+import qualified Generics.SOP.Type.Metadata as Type
38+import qualified GHC.Generics as GHC
39+import qualified PostgreSQL.Binary.Decoding as Decoding
40+import qualified PostgreSQL.Binary.Encoding as Encoding
2941
3042import Squeel.PostgreSQL.Schema
3143
32−decodeValue :: HasDecoding pg x => proxy pg -> ByteString -> Either Text x
33−decodeValue p = Decoder.valueParser $ decoding p
44+class ToParam x (pg :: PGType) where toParam :: x -> K Encoding.Encoding pg
45+instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
46+instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
47+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
48+instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
49+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
50+instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
51+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
52+instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
53+instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
54+instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
55+instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
56+instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
57+instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
58+instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
59+instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy
60+instance ToParam Strict.ByteString 'PGbytea where
61+ toParam = K . Encoding.bytea_strict
62+instance ToParam Lazy.ByteString 'PGbytea where
63+ toParam = K . Encoding.bytea_lazy
64+instance ToParam Day 'PGdate where toParam = K . Encoding.date
65+instance ToParam TimeOfDay 'PGtime where toParam = K . Encoding.time_int
66+instance ToParam (TimeOfDay, TimeZone) 'PGtimetz where
67+ toParam = K . Encoding.timetz_int
68+instance ToParam LocalTime 'PGtimestamp where
69+ toParam = K . Encoding.timestamp_int
70+instance ToParam UTCTime 'PGtimestamptz where
71+ toParam = K . Encoding.timestamptz_int
72+instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
73+instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast
74+instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
3475
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
76+class ToColumnParam x (ty :: ColumnType) where
77+ toColumnParam :: x -> K (Maybe Strict.ByteString) ty
78+instance ToParam x pg => ToColumnParam x ('Required ('NotNull pg)) where
79+ toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg
80+instance ToParam x pg => ToColumnParam (Maybe x) ('Required ('Null pg)) where
81+ toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
82+instance ToParam x pg => ToColumnParam (Maybe x) ('Optional (nullity pg)) where
83+ toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
7984
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
85+class SListI tys => ToParams x (tys :: [ColumnType]) where
86+ toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
87+instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
88+ => ToParams x tys where
89+ toParams
90+ = htrans (Proxy @ToColumnParam) (toColumnParam . unI)
91+ . unZ . unSOP . from
9092
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
93+class FromValue (pg :: PGType) y where
94+ fromValue :: proxy pg -> Decoding.Value y
95+instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool
96+instance (Integral int, Bits int) => FromValue 'PGint2 int where
97+ fromValue _ = Decoding.int
98+instance (Integral int, Bits int) => FromValue 'PGint4 int where
99+ fromValue _ = Decoding.int
100+instance (Integral int, Bits int) => FromValue 'PGint8 int where
101+ fromValue _ = Decoding.int
102+instance FromValue 'PGfloat4 Float where fromValue _ = Decoding.float4
103+instance FromValue 'PGfloat8 Double where fromValue _ = Decoding.float8
104+instance FromValue 'PGnumeric Scientific where fromValue _ = Decoding.numeric
105+instance FromValue 'PGuuid UUID where fromValue _ = Decoding.uuid
106+instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet
107+instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char
108+instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict
109+instance FromValue 'PGtext Lazy.Text where fromValue _ = Decoding.text_lazy
110+instance FromValue 'PGbytea Strict.ByteString where
111+ fromValue _ = Decoding.bytea_strict
112+instance FromValue 'PGbytea Lazy.ByteString where
113+ fromValue _ = Decoding.bytea_lazy
114+instance FromValue 'PGdate Day where fromValue _ = Decoding.date
115+instance FromValue 'PGtime TimeOfDay where fromValue _ = Decoding.time_int
116+instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
117+ fromValue _ = Decoding.timetz_int
118+instance FromValue 'PGtimestamp LocalTime where
119+ fromValue _ = Decoding.timestamp_int
120+instance FromValue 'PGtimestamptz UTCTime where
121+ fromValue _ = Decoding.timestamptz_int
122+instance FromValue 'PGinterval DiffTime where
123+ fromValue _ = Decoding.interval_int
124+instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast
125+instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast
135126
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
127+class FromColumnValue (colty :: (Symbol,ColumnType)) y where
128+ fromColumnValue :: K (Maybe Strict.ByteString) colty -> y
129+instance FromValue pg y
130+ => FromColumnValue (column ::: ('Required ('NotNull pg))) y where
131+ fromColumnValue = \case
132+ K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
133+ K (Just bytes) ->
134+ let
135+ errOrValue =
136+ Decoding.valueParser (fromValue @pg @y Proxy) bytes
137+ err str = error $ "fromColumnValue: " ++ Strict.unpack str
138+ in
139+ either err id errOrValue
140+instance FromValue pg y
141+ => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where
142+ fromColumnValue (K nullOrBytes)
143+ = either err id
144+ . Decoding.valueParser (fromValue @pg @y Proxy)
145+ <$> nullOrBytes
146+ where
147+ err str = error $ "fromColumnValue: " ++ Strict.unpack str
148+
149+class SListI columns => FromRow (columns :: [(Symbol,ColumnType)]) y where
150+ fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y
151+instance
152+ ( SListI columns, IsProductType y ys
153+ , AllZip FromColumnValue columns ys
154+ , HasDatatypeInfo y
155+ , SameFields (DatatypeInfoOf y) columns
156+ ) => FromRow columns y where
157+ fromRow
158+ = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
159+
160+class SameField
161+ (fieldInfo :: Type.FieldInfo) (columnty :: (Symbol,ColumnType)) where
162+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
163+
164+type family SameFields
165+ (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ColumnType)]) where
166+ SameFields
167+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
168+ columns
169+ = AllZip SameField fields columns
170+ SameFields
171+ ('Type.Newtype _module _datatype ('Type.Record _constructor '[field]))
172+ '[column]
173+ = SameField field column
174+
175+newtype Only x = Only { only :: x }
176+ deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
177+instance Generic (Only x)
178+instance HasDatatypeInfo (Only x)
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+26−52
@@ -22,13 +22,9 @@ 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
@@ -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
squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+42−58
@@ -15,10 +15,8 @@
1515
1616module Squeel.PostgreSQL.Schema
1717 ( PGType (..)
18− , ToOid (..)
19− , ToOids (..)
2018 , PGNum (..)
21− , PGFractional
19+ , PGIntegral
2220 , PGFloating
2321 , (:::)
2422 , Alias (Alias)
@@ -30,6 +28,7 @@ module Squeel.PostgreSQL.Schema
3028 , NullifyColumns
3129 , NullifyTables
3230 , ColumnType (..)
31+ , BaseType
3332 , Create
3433 , Drop
3534 , Alter
@@ -48,65 +47,47 @@ import GHC.Exts
4847import GHC.OverloadedLabels
4948import GHC.TypeLits
5049
51−import qualified Database.PostgreSQL.LibPQ as LibPQ
52−
5350data PGType
54− = PGBool
55− | PGInt2
56− | PGInt4
57− | PGInt8
58− | PGNumeric
59− | PGFloat4
60− | PGFloat8
61− | PGSerial2
62− | PGSerial4
63− | PGSerial8
64− | PGMoney
65− | PGChar Nat
66− | PGVarChar Nat
67− | PGText
68− | PGBytea
69− | PGTimestamp
70− | PGTimestampTZ
71− | PGDate
72− | PGTime
73− | PGTimeTZ
74− | PGInterval
75− | PGUuid
76− | PGJson
77− | PGJsonb
78−
79−class ToOid pg where toOid :: Proxy# pg -> LibPQ.Oid
80−--staticTypeInfo
81−instance ToOid ('Required ('NotNull 'PGBool)) where toOid _ = LibPQ.Oid 16
82−instance ToOid ('Required ('NotNull 'PGBytea)) where toOid _ = LibPQ.Oid 17
83−instance ToOid ('Required ('NotNull 'PGInt8)) where toOid _ = LibPQ.Oid 20
84−instance ToOid ('Required ('NotNull 'PGInt2)) where toOid _ = LibPQ.Oid 21
85−instance ToOid ('Required ('NotNull 'PGInt4)) where toOid _ = LibPQ.Oid 23
86−instance ToOid ('Required ('NotNull 'PGText)) where toOid _ = LibPQ.Oid 26
87−class ToOids pgs where toOids :: Proxy# pgs -> [LibPQ.Oid]
88−instance ToOids '[] where toOids _ = []
89−instance (ToOid pg, ToOids pgs) => ToOids (pg ': pgs) where
90− toOids _ = toOid (proxy# :: Proxy# pg) : toOids (proxy# :: Proxy# pgs)
51+ = PGbool
52+ | PGint2
53+ | PGint4
54+ | PGint8
55+ | PGnumeric
56+ | PGfloat4
57+ | PGfloat8
58+ | PGchar Nat
59+ | PGvarchar Nat
60+ | PGtext
61+ | PGbytea
62+ | PGtimestamp
63+ | PGtimestamptz
64+ | PGdate
65+ | PGtime
66+ | PGtimetz
67+ | PGinterval
68+ | PGuuid
69+ | PGinet
70+ | PGjson
71+ | PGjsonb
9172
9273class PGNum (ty :: PGType) where
9374 decimal :: proxy ty -> Bool
94−instance PGNum 'PGInt2 where decimal _ = False
95−instance PGNum 'PGInt4 where decimal _ = False
96−instance PGNum 'PGInt8 where decimal _ = False
97−instance PGNum 'PGNumeric where decimal _ = True
98−instance PGNum 'PGFloat4 where decimal _ = True
99−instance PGNum 'PGFloat8 where decimal _ = True
100−
101−class PGNum ty => PGFractional (ty :: PGType) where
102−instance PGFractional 'PGNumeric
103−instance PGFractional 'PGFloat4
104−instance PGFractional 'PGFloat8
105−
106−class PGFractional ty => PGFloating (ty :: PGType) where
107−instance PGFloating 'PGNumeric
108−instance PGFloating 'PGFloat4
109−instance PGFloating 'PGFloat8
75+instance PGNum 'PGint2 where decimal _ = False
76+instance PGNum 'PGint4 where decimal _ = False
77+instance PGNum 'PGint8 where decimal _ = False
78+instance PGNum 'PGnumeric where decimal _ = True
79+instance PGNum 'PGfloat4 where decimal _ = True
80+instance PGNum 'PGfloat8 where decimal _ = True
81+
82+class PGNum ty => PGIntegral (ty :: PGType) where
83+instance PGIntegral 'PGint2
84+instance PGIntegral 'PGint4
85+instance PGIntegral 'PGint8
86+
87+class PGNum ty => PGFloating (ty :: PGType) where
88+instance PGFloating 'PGnumeric
89+instance PGFloating 'PGfloat4
90+instance PGFloating 'PGfloat8
11091
11192type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)
11293
@@ -136,6 +117,9 @@ data NullityType = Null PGType | NotNull PGType
136117
137118data ColumnType = Optional NullityType | Required NullityType
138119
120+type family BaseType (ty :: ColumnType) where
121+ BaseType (optionality (nullity pg)) = pg
122+
139123type family NullifyType (ty :: ColumnType) where
140124 NullifyType (optionality ('Null ty)) = optionality ('Null ty)
141125 NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)
squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+100−124
@@ -49,24 +49,17 @@ newtype Expression
4949 = UnsafeExpression { renderExpression :: ByteString }
5050 deriving (Show,Eq)
5151
52−class KnownNat n => HasParameter (n :: Nat) params ty | n params -> ty where
53− param :: Proxy# n -> Expression params tables grouping ty
54− param p = UnsafeExpression $ ("$" <>) $ fromString $ show $ natVal' p
55−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
52+class (PGTyped (BaseType ty), KnownNat n)
53+ => HasParameter (n :: Nat) params ty | n params -> ty where
54+ param :: proxy n -> Expression params tables grouping ty
55+ param _ = UnsafeExpression $ parenthesized $
56+ "$" <> renderNat (Proxy @n) <+> "::"
57+ <+> renderTypeExpression (pgtype @(BaseType ty))
58+instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)
59+ => HasParameter 1 (ty1:tys) ty1
5660instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
5761 => HasParameter n (ty' : params) ty
5862
59−param1 :: Expression (ty1:tys) tables grouping ty1
60−param1 = param (proxy# :: Proxy# 1)
61−param2 :: Expression (ty1:ty2:tys) tables grouping ty2
62−param2 = param (proxy# :: Proxy# 2)
63−param3 :: Expression (ty1:ty2:ty3:tys) tables grouping ty3
64−param3 = param (proxy# :: Proxy# 3)
65−param4 :: Expression (ty1:ty2:ty3:ty4:tys) tables grouping ty4
66−param4 = param (proxy# :: Proxy# 4)
67−param5 :: Expression (ty1:ty2:ty3:ty4:ty5:tys) tables grouping ty5
68−param5 = param (proxy# :: Proxy# 5)
69−
7063class KnownSymbol column => HasColumn column columns ty
7164 | column columns -> ty where
7265 getColumn
@@ -146,12 +139,12 @@ instance PGNum ty
146139 . fromString
147140 . show
148141
149−instance PGFractional ty => Fractional
142+instance PGFloating ty => Fractional
150143 (Expression params tables grouping ('Required (nullity ty))) where
151144 (/) = unsafeBinaryOp "/"
152145 fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
153146
154−instance (PGFloating ty, PGCast 'PGNumeric ty, PGTyped ty) => Floating
147+instance (PGFloating ty, PGTyped ty) => Floating
155148 (Expression params tables grouping ('Required (nullity ty))) where
156149 pi = UnsafeExpression "pi()"
157150 exp = unsafeFunction "exp"
@@ -164,12 +157,12 @@ instance (PGFloating ty, PGCast 'PGNumeric ty, PGTyped ty) => Floating
164157 logBaseNumeric
165158 :: Expression params tables grouping ('Required (nullity ty))
166159 -> Expression params tables grouping ('Required (nullity ty))
167− -> Expression params tables grouping ('Required (nullity 'PGNumeric))
160+ -> Expression params tables grouping ('Required (nullity 'PGnumeric))
168161 logBaseNumeric b' y' = UnsafeExpression $ mconcat
169162 [ "log("
170− , renderExpression b' <> "::numeric"
163+ , renderExpression (cast numeric b')
171164 , ", "
172− , renderExpression y' <> "::numeric"
165+ , renderExpression (cast numeric y')
173166 , ")"
174167 ]
175168 sin = unsafeFunction "sin"
@@ -193,75 +186,62 @@ atan2
193186atan2 y x = UnsafeExpression $
194187 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
195188
196−class PGCast (ty0 :: PGType) (ty1 :: PGType) where
197− cast
198− :: TypeExpression ('Required ('Null ty1))
199− -> Expression params tables grouping ('Required (nullity ty0))
200− -> Expression params tables grouping ('Required (nullity ty1))
201− cast ty x = UnsafeExpression $
202− "(" <> renderExpression x <> "::" <> renderTypeExpression ty <> ")"
203−instance PGCast 'PGInt2 'PGInt2
204−instance PGCast 'PGInt2 'PGInt4
205−instance PGCast 'PGInt2 'PGInt8
206−instance PGCast 'PGInt4 'PGInt2
207−instance PGCast 'PGInt4 'PGInt4
208−instance PGCast 'PGInt4 'PGInt8
209−instance PGCast 'PGInt8 'PGInt2
210−instance PGCast 'PGInt8 'PGInt4
211−instance PGCast 'PGInt8 'PGInt8
212−instance PGCast 'PGInt8 'PGFloat4
213−instance PGCast 'PGInt8 'PGFloat8
214−instance PGCast 'PGInt8 'PGNumeric
189+cast
190+ :: TypeExpression ('Required ('Null ty1))
191+ -> Expression params tables grouping ('Required (nullity ty0))
192+ -> Expression params tables grouping ('Required (nullity ty1))
193+cast ty x = UnsafeExpression $ parenthesized $
194+ renderExpression x <+> "::" <+> renderTypeExpression ty
215195
216196div
217− :: (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
197+ :: PGIntegral ty
218198 => Expression params tables grouping ('Required (nullity ty))
219199 -> Expression params tables grouping ('Required (nullity ty))
220200 -> Expression params tables grouping ('Required (nullity ty))
221201div = unsafeBinaryOp "/"
222202
223203mod
224− :: (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
204+ :: PGIntegral ty
225205 => Expression params tables grouping ('Required (nullity ty))
226206 -> Expression params tables grouping ('Required (nullity ty))
227207 -> Expression params tables grouping ('Required (nullity ty))
228208mod = unsafeBinaryOp "%"
229209
230210truncate
231− :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
211+ :: (PGFloating frac, PGTyped int)
232212 => Expression params tables grouping ('Required (nullity frac))
233213 -> Expression params tables grouping ('Required (nullity int))
234214truncate = cast pgtype . truncate'
235215 where
236216 truncate'
237217 :: Expression params tables grouping ('Required (nullity frac))
238− -> Expression params tables grouping ('Required (nullity 'PGInt4))
218+ -> Expression params tables grouping ('Required (nullity frac))
239219 truncate' = unsafeFunction "trunc"
240220
241221round
242− :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
222+ :: (PGFloating frac, PGTyped int)
243223 => Expression params tables grouping ('Required (nullity frac))
244224 -> Expression params tables grouping ('Required (nullity int))
245225round = cast pgtype . round'
246226 where
247227 round'
248228 :: Expression params tables grouping ('Required (nullity frac))
249− -> Expression params tables grouping ('Required (nullity 'PGInt4))
229+ -> Expression params tables grouping ('Required (nullity frac))
250230 round' = unsafeFunction "round"
251231
252232ceiling
253− :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
233+ :: (PGFloating frac, PGTyped int)
254234 => Expression params tables grouping ('Required (nullity frac))
255235 -> Expression params tables grouping ('Required (nullity int))
256236ceiling = cast pgtype . ceiling'
257237 where
258238 ceiling'
259239 :: Expression params tables grouping ('Required (nullity frac))
260− -> Expression params tables grouping ('Required (nullity 'PGInt4))
240+ -> Expression params tables grouping ('Required (nullity frac))
261241 ceiling' = unsafeFunction "ceiling"
262242
263243instance IsString
264− (Expression params tables grouping ('Required (nullity 'PGText))) where
244+ (Expression params tables grouping ('Required (nullity 'PGtext))) where
265245 fromString str = UnsafeExpression $
266246 "E\'" <> fromString (escape =<< str) <> "\'"
267247 where
@@ -277,7 +257,7 @@ instance IsString
277257 c -> [c]
278258
279259type Condition params tables grouping =
280− Expression params tables grouping ('Required ('NotNull 'PGBool))
260+ Expression params tables grouping ('Required ('NotNull 'PGbool))
281261
282262true :: Condition params tables grouping
283263true = UnsafeExpression "TRUE"
@@ -329,37 +309,37 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
329309(==*)
330310 :: Expression params tables grouping ('Required (nullity ty))
331311 -> Expression params tables grouping ('Required (nullity ty))
332− -> Expression params tables grouping ('Required (nullity 'PGBool))
312+ -> Expression params tables grouping ('Required (nullity 'PGbool))
333313(==*) = unsafeBinaryOp "="
334314
335315(/=*)
336316 :: Expression params tables grouping ('Required (nullity ty))
337317 -> Expression params tables grouping ('Required (nullity ty))
338− -> Expression params tables grouping ('Required (nullity 'PGBool))
318+ -> Expression params tables grouping ('Required (nullity 'PGbool))
339319(/=*) = unsafeBinaryOp "<>"
340320
341321(>=*)
342322 :: Expression params tables grouping ('Required (nullity ty))
343323 -> Expression params tables grouping ('Required (nullity ty))
344− -> Expression params tables grouping ('Required (nullity 'PGBool))
324+ -> Expression params tables grouping ('Required (nullity 'PGbool))
345325(>=*) = unsafeBinaryOp ">="
346326
347327(<*)
348328 :: Expression params tables grouping ('Required (nullity ty))
349329 -> Expression params tables grouping ('Required (nullity ty))
350− -> Expression params tables grouping ('Required (nullity 'PGBool))
330+ -> Expression params tables grouping ('Required (nullity 'PGbool))
351331(<*) = unsafeBinaryOp "<"
352332
353333(<=*)
354334 :: Expression params tables grouping ('Required (nullity ty))
355335 -> Expression params tables grouping ('Required (nullity ty))
356− -> Expression params tables grouping ('Required (nullity 'PGBool))
336+ -> Expression params tables grouping ('Required (nullity 'PGbool))
357337(<=*) = unsafeBinaryOp "<="
358338
359339(>*)
360340 :: Expression params tables grouping ('Required (nullity ty))
361341 -> Expression params tables grouping ('Required (nullity ty))
362− -> Expression params tables grouping ('Required (nullity 'PGBool))
342+ -> Expression params tables grouping ('Required (nullity 'PGbool))
363343(>*) = unsafeBinaryOp ">"
364344
365345data SortExpression params tables grouping where
@@ -428,7 +408,7 @@ class (KnownSymbol table, KnownSymbol column)
428408 :: (tables ~ '[table ::: columns], HasColumn column columns ty)
429409 => Proxy# column
430410 -> Expression params tables ('Grouped bys) ty
431− getGroup1 column = UnsafeExpression $ fromString (symbolVal' column)
411+ getGroup1 column = UnsafeExpression $ renderSymbol column
432412 getGroup2
433413 :: (HasTable table tables columns, HasColumn column columns ty)
434414 => Alias table
@@ -484,7 +464,7 @@ newtype Table
484464class KnownSymbol table => HasTable table tables columns
485465 | table tables -> columns where
486466 getTable :: Proxy# table -> Table tables columns
487− getTable table = UnsafeTable $ fromString $ symbolVal' table
467+ getTable table = UnsafeTable $ renderSymbol table
488468instance {-# OVERLAPPING #-} KnownSymbol table
489469 => HasTable table ((table ::: columns) ': tables) columns
490470instance {-# OVERLAPPABLE #-}
@@ -646,91 +626,86 @@ newtype TypeExpression (ty :: ColumnType)
646626 = UnsafeTypeExpression { renderTypeExpression :: ByteString }
647627 deriving (Show,Eq)
648628
649−bool :: TypeExpression ('Required ('Null 'PGBool))
629+bool :: TypeExpression ('Required ('Null 'PGbool))
650630bool = UnsafeTypeExpression "bool"
651−int2 :: TypeExpression ('Required ('Null 'PGInt2))
631+int2 :: TypeExpression ('Required ('Null 'PGint2))
652632int2 = UnsafeTypeExpression "int2"
653−smallint :: TypeExpression ('Required ('Null 'PGInt2))
633+smallint :: TypeExpression ('Required ('Null 'PGint2))
654634smallint = UnsafeTypeExpression "smallint"
655−int4 :: TypeExpression ('Required ('Null 'PGInt4))
635+int4 :: TypeExpression ('Required ('Null 'PGint4))
656636int4 = UnsafeTypeExpression "int4"
657−int :: TypeExpression ('Required ('Null 'PGInt4))
637+int :: TypeExpression ('Required ('Null 'PGint4))
658638int = UnsafeTypeExpression "int"
659−integer :: TypeExpression ('Required ('Null 'PGInt4))
639+integer :: TypeExpression ('Required ('Null 'PGint4))
660640integer = UnsafeTypeExpression "integer"
661−int8 :: TypeExpression ('Required ('Null 'PGInt8))
641+int8 :: TypeExpression ('Required ('Null 'PGint8))
662642int8 = UnsafeTypeExpression "int8"
663−bigint :: TypeExpression ('Required ('Null 'PGInt8))
643+bigint :: TypeExpression ('Required ('Null 'PGint8))
664644bigint = UnsafeTypeExpression "bigint"
665−numeric :: TypeExpression ('Required ('Null 'PGNumeric))
645+numeric :: TypeExpression ('Required ('Null 'PGnumeric))
666646numeric = UnsafeTypeExpression "numeric"
667−float4 :: TypeExpression ('Required ('Null 'PGFloat4))
647+float4 :: TypeExpression ('Required ('Null 'PGfloat4))
668648float4 = UnsafeTypeExpression "float4"
669−real :: TypeExpression ('Required ('Null 'PGFloat4))
649+real :: TypeExpression ('Required ('Null 'PGfloat4))
670650real = UnsafeTypeExpression "real"
671−float8 :: TypeExpression ('Required ('Null 'PGFloat8))
651+float8 :: TypeExpression ('Required ('Null 'PGfloat8))
672652float8 = UnsafeTypeExpression "float8"
673−doublePrecision :: TypeExpression ('Required ('Null 'PGFloat8))
653+doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))
674654doublePrecision = UnsafeTypeExpression "double precision"
675−serial2 :: TypeExpression ('Optional ('NotNull 'PGInt2))
655+serial2 :: TypeExpression ('Optional ('NotNull 'PGint2))
676656serial2 = UnsafeTypeExpression "serial2"
677−smallserial :: TypeExpression ('Optional ('NotNull 'PGInt2))
657+smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))
678658smallserial = UnsafeTypeExpression "smallserial"
679−serial4 :: TypeExpression ('Optional ('NotNull 'PGInt4))
659+serial4 :: TypeExpression ('Optional ('NotNull 'PGint4))
680660serial4 = UnsafeTypeExpression "serial4"
681−serial :: TypeExpression ('Optional ('NotNull 'PGInt4))
661+serial :: TypeExpression ('Optional ('NotNull 'PGint4))
682662serial = UnsafeTypeExpression "serial"
683−serial8 :: TypeExpression ('Optional ('NotNull 'PGInt8))
663+serial8 :: TypeExpression ('Optional ('NotNull 'PGint8))
684664serial8 = UnsafeTypeExpression "serial8"
685−bigserial :: TypeExpression ('Optional ('NotNull 'PGInt8))
665+bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))
686666bigserial = UnsafeTypeExpression "bigserial"
687−money :: TypeExpression ('Required ('Null 'PGMoney))
688−money = UnsafeTypeExpression "money"
689−text :: TypeExpression ('Required ('Null 'PGText))
667+text :: TypeExpression ('Required ('Null 'PGtext))
690668text = UnsafeTypeExpression "text"
691669char
692670 :: KnownNat n
693671 => proxy n
694− -> TypeExpression ('Required ('Null ('PGChar n)))
695−char (_ :: proxy n) = UnsafeTypeExpression $
696− "char(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
672+ -> TypeExpression ('Required ('Null ('PGchar n)))
673+char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
697674character
698675 :: KnownNat n
699676 => proxy n
700− -> TypeExpression ('Required ('Null ('PGChar n)))
701−character (_ :: proxy n) = UnsafeTypeExpression $
702− "character(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
677+ -> TypeExpression ('Required ('Null ('PGchar n)))
678+character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
703679varchar
704680 :: KnownNat n
705681 => proxy n
706− -> TypeExpression ('Required ('Null ('PGVarChar n)))
707−varchar (_ :: proxy n) = UnsafeTypeExpression $
708− "varchar(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
682+ -> TypeExpression ('Required ('Null ('PGvarchar n)))
683+varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
709684characterVarying
710685 :: KnownNat n
711686 => proxy n
712− -> TypeExpression ('Required ('Null ('PGVarChar n)))
713−characterVarying (_ :: proxy n) = UnsafeTypeExpression $
714− "character varying(" <> fromString (show (natVal' (proxy# :: Proxy# n))) <> ")"
715−bytea :: TypeExpression ('Required ('Null ('PGBytea)))
687+ -> TypeExpression ('Required ('Null ('PGvarchar n)))
688+characterVarying p = UnsafeTypeExpression $
689+ "character varying(" <> renderNat p <> ")"
690+bytea :: TypeExpression ('Required ('Null ('PGbytea)))
716691bytea = UnsafeTypeExpression "bytea"
717−timestamp :: TypeExpression ('Required ('Null ('PGTimestamp)))
692+timestamp :: TypeExpression ('Required ('Null ('PGtimestamp)))
718693timestamp = UnsafeTypeExpression "timestamp"
719−timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGTimestampTZ)))
694+timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGtimestamptz)))
720695timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
721−date :: TypeExpression ('Required ('Null ('PGDate)))
696+date :: TypeExpression ('Required ('Null ('PGdate)))
722697date = UnsafeTypeExpression "date"
723−time :: TypeExpression ('Required ('Null ('PGTime)))
698+time :: TypeExpression ('Required ('Null ('PGtime)))
724699time = UnsafeTypeExpression "time"
725−timeWithTimeZone :: TypeExpression ('Required ('Null ('PGTimeTZ)))
700+timeWithTimeZone :: TypeExpression ('Required ('Null ('PGtimetz)))
726701timeWithTimeZone = UnsafeTypeExpression "time with time zone"
727−interval :: TypeExpression ('Required ('Null ('PGInterval)))
702+interval :: TypeExpression ('Required ('Null ('PGinterval)))
728703interval = UnsafeTypeExpression "interval"
729−uuid :: TypeExpression ('Required ('Null ('PGUuid)))
704+uuid :: TypeExpression ('Required ('Null ('PGuuid)))
730705uuid = UnsafeTypeExpression "uuid"
731−json :: TypeExpression ('Required ('Null ('PGJson)))
706+json :: TypeExpression ('Required ('Null ('PGjson)))
732707json = UnsafeTypeExpression "json"
733−jsonb :: TypeExpression ('Required ('Null ('PGJsonb)))
708+jsonb :: TypeExpression ('Required ('Null ('PGjsonb)))
734709jsonb = UnsafeTypeExpression "jsonb"
735710
736711notNull
@@ -746,27 +721,26 @@ default_ x ty = UnsafeTypeExpression $
746721
747722class PGTyped (ty :: PGType) where
748723 pgtype :: TypeExpression ('Required ('Null ty))
749−instance PGTyped 'PGBool where pgtype = bool
750−instance PGTyped 'PGInt2 where pgtype = int2
751−instance PGTyped 'PGInt4 where pgtype = int4
752−instance PGTyped 'PGInt8 where pgtype = int8
753−instance PGTyped 'PGNumeric where pgtype = numeric
754−instance PGTyped 'PGFloat4 where pgtype = float4
755−instance PGTyped 'PGFloat8 where pgtype = float8
756−instance PGTyped 'PGMoney where pgtype = money
757−instance PGTyped 'PGText where pgtype = text
758−instance KnownNat n => PGTyped ('PGChar n) where pgtype = char (Proxy @n)
759−instance KnownNat n => PGTyped ('PGVarChar n) where pgtype = varchar (Proxy @n)
760−instance PGTyped 'PGBytea where pgtype = bytea
761−instance PGTyped 'PGTimestamp where pgtype = timestamp
762−instance PGTyped 'PGTimestampTZ where pgtype = timestampWithTimeZone
763−instance PGTyped 'PGDate where pgtype = date
764−instance PGTyped 'PGTime where pgtype = time
765−instance PGTyped 'PGTimeTZ where pgtype = timeWithTimeZone
766−instance PGTyped 'PGInterval where pgtype = interval
767−instance PGTyped 'PGUuid where pgtype = uuid
768−instance PGTyped 'PGJson where pgtype = json
769−instance PGTyped 'PGJsonb where pgtype = jsonb
724+instance PGTyped 'PGbool where pgtype = bool
725+instance PGTyped 'PGint2 where pgtype = int2
726+instance PGTyped 'PGint4 where pgtype = int4
727+instance PGTyped 'PGint8 where pgtype = int8
728+instance PGTyped 'PGnumeric where pgtype = numeric
729+instance PGTyped 'PGfloat4 where pgtype = float4
730+instance PGTyped 'PGfloat8 where pgtype = float8
731+instance PGTyped 'PGtext where pgtype = text
732+instance KnownNat n => PGTyped ('PGchar n) where pgtype = char (Proxy @n)
733+instance KnownNat n => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)
734+instance PGTyped 'PGbytea where pgtype = bytea
735+instance PGTyped 'PGtimestamp where pgtype = timestamp
736+instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone
737+instance PGTyped 'PGdate where pgtype = date
738+instance PGTyped 'PGtime where pgtype = time
739+instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone
740+instance PGTyped 'PGinterval where pgtype = interval
741+instance PGTyped 'PGuuid where pgtype = uuid
742+instance PGTyped 'PGjson where pgtype = json
743+instance PGTyped 'PGjsonb where pgtype = jsonb
770744
771745{-----------------------------------------
772746statements
@@ -1049,8 +1023,7 @@ dropNotNull
10491023dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
10501024
10511025alterType
1052− :: PGCast ty0 ty1
1053− => TypeExpression (optionality (nullity ty1))
1026+ :: TypeExpression (optionality (nullity ty1))
10541027 -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))
10551028alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty
10561029
@@ -1216,3 +1189,6 @@ renderCommaSeparatedMaybe render
12161189
12171190renderSymbol :: KnownSymbol str => Proxy# str -> ByteString
12181191renderSymbol p = fromString $ symbolVal' p
1192+
1193+renderNat :: KnownNat n => proxy n -> ByteString
1194+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+29−24
@@ -3,6 +3,7 @@
33 , MagicHash
44 , OverloadedLabels
55 , OverloadedStrings
6+ , TypeApplications
67 , TypeOperators
78#-}
89
@@ -66,10 +67,11 @@ spec = do
6667 statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
6768 it "should render parameters using $ signs" $ do
6869 let
69− statement :: Query Tables '[ 'Required ('NotNull 'PGBool)] Columns
70− statement =
71− selectStar (from (Table (#table1 `As` #table1)) & where_ param1)
72− statement `queryRenders` "SELECT * FROM table1 AS table1 WHERE $1;"
70+ statement :: Query Tables '[ 'Required ('NotNull 'PGbool)] Columns
71+ statement = selectStar
72+ (from (Table (#table1 `As` #table1)) & where_ (param (Proxy @1)))
73+ statement `queryRenders`
74+ "SELECT * FROM table1 AS table1 WHERE ($1 :: bool);"
7375 it "does OFFSET clauses" $ do
7476 let
7577 statement :: Query Tables '[] Columns
@@ -247,13 +249,13 @@ spec = do
247249 let
248250 statement :: Definition '[]
249251 '[ "users" :::
250− '[ "id" ::: 'Optional ('NotNull 'PGInt4)
251− , "username" ::: 'Required ('NotNull 'PGText)
252+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
253+ , "username" ::: 'Required ('NotNull 'PGtext)
252254 ]
253255 , "emails" :::
254− '[ "id" ::: 'Optional ('NotNull 'PGInt4)
255− , "userid" ::: 'Required ('NotNull 'PGInt4)
256− , "email" ::: 'Required ('NotNull 'PGText)
256+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
257+ , "userid" ::: 'Required ('NotNull 'PGint4)
258+ , "email" ::: 'Required ('NotNull 'PGtext)
257259 ]
258260 ]
259261 statement =
@@ -290,26 +292,29 @@ spec = do
290292 statement `definitionRenders` "DROP TABLE table1;"
291293
292294type Columns =
293− '[ "col1" ::: 'Required ('NotNull 'PGInt4)
294− , "col2" ::: 'Required ('NotNull 'PGInt4)
295+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
296+ , "col2" ::: 'Required ('NotNull 'PGint4)
295297 ]
296298type Tables = '[ "table1" ::: Columns ]
297−type SumAndCol1 = '[ "sum" ::: 'Required ('NotNull 'PGInt4), "col1" ::: 'Required ('NotNull 'PGInt4)]
298−type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]
299+type SumAndCol1 =
300+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
301+ , "col1" ::: 'Required ('NotNull 'PGint4)
302+ ]
303+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
299304type StudentsTable = '["students" ::: StudentsColumns]
300305type OrderColumns =
301− '[ "orderID" ::: 'Required ('NotNull 'PGInt4)
302− , "orderVal" ::: 'Required ('NotNull 'PGText)
303− , "customerID" ::: 'Required ('NotNull 'PGInt4)
304− , "shipperID" ::: 'Required ('NotNull 'PGInt4)
306+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)
307+ , "orderVal" ::: 'Required ('NotNull 'PGtext)
308+ , "customerID" ::: 'Required ('NotNull 'PGint4)
309+ , "shipperID" ::: 'Required ('NotNull 'PGint4)
305310 ]
306311type CustomerColumns =
307− '[ "customerID" ::: 'Required ('NotNull 'PGInt4)
308− , "customerVal" ::: 'Required ('NotNull 'PGFloat4)
312+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)
313+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
309314 ]
310315type ShipperColumns =
311− '[ "shipperID" ::: 'Required ('NotNull 'PGInt4)
312− , "shipperVal" ::: 'Required ('NotNull 'PGBool)
316+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
317+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
313318 ]
314319type JoinTables =
315320 '[ "orders" ::: OrderColumns
@@ -317,7 +322,7 @@ type JoinTables =
317322 , "shippers" ::: ShipperColumns
318323 ]
319324type ValueColumns =
320− '[ "orderVal" ::: 'Required ('NotNull 'PGText)
321− , "customerVal" ::: 'Required ('NotNull 'PGFloat4)
322− , "shipperVal" ::: 'Required ('NotNull 'PGBool)
325+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
326+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
327+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
323328 ]