git.iko.soy/squeal
on dev help sign in
Merge pull request #21 from echatav/create-complex

Create complex

commitf707a33dd790d1bd14cf61ffbc762ee3f034d2a5 authorEitan Chatav <eitan.chatav@gmail.com> dateTue 27 Jun 2017, 22:48 (9 years ago) parentd0486fc40400fa
9 files changed+443−313
compare with dev
unifiedsplit
squeel-postgresql/exe/Example.hs+82 squeel-postgresql/squeel-postgresql.cabal+13 squeel-postgresql/src/Squeel/PostgreSQL.hs+11 squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+13−11 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+31−24 squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+15−83 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+219−144 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+58−44 stack.yaml+1−7
squeel-postgresql/exe/Example.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , MagicHash
4+ , OverloadedLabels
5+ , OverloadedStrings
6+ , TypeOperators
7+#-}
8+
9+module Main (main) where
10+
11+import Control.Category ((>>>))
12+import Control.Monad.Base
13+import Data.Function ((&))
14+import Data.Int
15+import Data.Monoid
16+import Data.Vinyl
17+import Squeel.PostgreSQL
18+
19+import qualified Data.ByteString.Char8 as Char8
20+
21+main :: IO ()
22+main = do
23+ Char8.putStrLn "squeel"
24+ connectionString <- pure
25+ "host=localhost port=5432 dbname=exampledb"
26+ Char8.putStrLn $ "connecting to " <> connectionString
27+ connection0 <- connectdb connectionString
28+ Char8.putStrLn "creating tables"
29+ connection1 <- flip execPQ connection0 $ pqExec $
30+ createTable #students
31+ ( (text & notNull) `As` #name
32+ :& RNil )
33+ >>>
34+ createTable #table1
35+ ( (int4 & notNull) `As` #col1
36+ :& (int4 & notNull) `As` #col2
37+ :& RNil )
38+ connection2 <- flip execPQ connection1 $ do
39+ _insertTable1Result <- pqExec $
40+ insertInto #table1 ( 1 `As` #col1 :& 2 `As` #col2 :& RNil )
41+ >>>
42+ insertInto #table1 ( 3 `As` #col1 :& 4 `As` #col2 :& RNil )
43+ Just selectTable1Result <- flip pqExecParams RNil $
44+ (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
49+ liftBase $ do
50+ print (value00 :: Int32)
51+ print (value01 :: Int32)
52+ print (value10 :: Int32)
53+ print (value11 :: Int32)
54+ finish connection2
55+
56+type Columns =
57+ '[ "col1" ::: 'Required ('NotNull 'PGInt4)
58+ , "col2" ::: 'Required ('NotNull 'PGInt4)
59+ ]
60+-- type SumAndCol1 = '[ "sum" ::: 'NotNull 'PGInt4, "col1" ::: 'NotNull 'PGInt4]
61+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]
62+type Tables = '[ "table1" ::: Columns, "students" ::: StudentsColumns]
63+-- type OrderColumns =
64+-- [ "orderID" ::: 'NotNull 'PGInt4
65+-- , "orderVal" ::: 'NotNull 'PGText
66+-- , "customerID" ::: 'NotNull 'PGInt4
67+-- , "shipperID" ::: 'NotNull 'PGInt4
68+-- ]
69+-- type CustomerColumns =
70+-- [ "customerID" ::: 'NotNull 'PGInt4, "customerVal" ::: 'NotNull 'PGFloat4 ]
71+-- type ShipperColumns =
72+-- [ "shipperID" ::: 'NotNull 'PGInt4, "shipperVal" ::: 'NotNull 'PGBool ]
73+-- type JoinTables =
74+-- [ "shippers" ::: ShipperColumns
75+-- , "customers" ::: CustomerColumns
76+-- , "orders" ::: OrderColumns
77+-- ]
78+-- type ValueColumns =
79+-- [ "orderVal" ::: 'NotNull 'PGText
80+-- , "customerVal" ::: 'NotNull 'PGFloat4
81+-- , "shipperVal" ::: 'NotNull 'PGBool
82+-- ]
squeel-postgresql/squeel-postgresql.cabal+13
@@ -13,6 +13,7 @@ cabal-version: >=1.10
1313library
1414 hs-source-dirs: src
1515 exposed-modules:
16+ Squeel.PostgreSQL
1617 Squeel.PostgreSQL.Binary
1718 Squeel.PostgreSQL.PQ
1819 Squeel.PostgreSQL.Statement
@@ -52,6 +53,18 @@ test-suite squeel-postgresql-test
5253 , squeel-postgresql
5354 , vinyl
5455
56+executable squeel-postgresql-example
57+ default-language: Haskell2010
58+ hs-source-dirs: exe
59+ ghc-options: -Wall -Werror
60+ main-is: Example.hs
61+ build-depends:
62+ base
63+ , bytestring
64+ , squeel-postgresql
65+ , transformers-base
66+ , vinyl
67+
5568source-repository head
5669 type: git
5770 location: https://github.com/echatav/squeel
squeel-postgresql/src/Squeel/PostgreSQL.hsnew file+11
@@ -0,0 +1,11 @@
1+module Squeel.PostgreSQL
2+ ( module Squeel.PostgreSQL.Binary
3+ , module Squeel.PostgreSQL.PQ
4+ , module Squeel.PostgreSQL.Schema
5+ , module Squeel.PostgreSQL.Statement
6+ ) where
7+
8+import Squeel.PostgreSQL.Binary
9+import Squeel.PostgreSQL.PQ
10+import Squeel.PostgreSQL.Schema
11+import Squeel.PostgreSQL.Statement
squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+13−11
@@ -17,8 +17,8 @@ import Data.ByteString (ByteString)
1717import Data.Int (Int16,Int32,Int64)
1818import Data.Vinyl
1919import Data.Vinyl.Functor
20−import PostgreSQL.Binary.Decoder (Decoder)
21−import PostgreSQL.Binary.Encoder (Encoder)
20+import PostgreSQL.Binary.Decoding (Value)
21+import PostgreSQL.Binary.Encoding (Encoding)
2222import Data.Scientific (Scientific)
2323import Data.Text (Text)
2424import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
@@ -28,16 +28,16 @@ import GHC.Exts
2828import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
2929import qualified Data.Text as Text (pack)
3030import qualified Data.Text.Lazy as Lazy (Text)
31−import qualified PostgreSQL.Binary.Decoder as Decoder
32−import qualified PostgreSQL.Binary.Encoder as Encoder
31+import qualified PostgreSQL.Binary.Decoding as Decoder
32+import qualified PostgreSQL.Binary.Encoding as Encoder
3333
3434import Squeel.PostgreSQL.Schema
3535
3636decodeValue :: FromValue pg x => Proxy# pg -> ByteString -> Either Text x
37−decodeValue p = Decoder.run $ fromValue p
37+decodeValue p = Decoder.valueParser $ fromValue p
3838
39−class FromValue (pg :: PGType) x where
40− fromValue :: Proxy# pg -> Decoder x
39+class FromValue pg x where
40+ fromValue :: Proxy# pg -> Value x
4141instance FromValue 'PGInt2 Int16 where
4242 fromValue _ = Decoder.int
4343instance FromValue 'PGInt4 Int32 where
@@ -80,6 +80,8 @@ instance FromValue 'PGTimestampTZ UTCTime where
8080 fromValue _ = Decoder.timestamptz_int
8181instance FromValue 'PGInterval DiffTime where
8282 fromValue _ = Decoder.interval_int
83+instance FromValue pg ty => FromValue (column ::: 'Required ('NotNull pg)) ty where
84+ fromValue _ = fromValue (proxy# :: Proxy# pg)
8385
8486class FromValues pgs xs where
8587 decodeValues :: Proxy# pgs -> Rec (Const ByteString) xs -> Rec (Either Text) xs
@@ -90,8 +92,8 @@ instance (FromValue pg x, FromValues pgs xs)
9092 decodeValue (proxy# :: Proxy# pg) result
9193 :& decodeValues (proxy# :: Proxy# pgs) results
9294
93−class ToValue x (pg :: PGType) where
94− toValue :: Proxy# pg -> Encoder x
95+class ToValue x pg where
96+ toValue :: Proxy# pg -> x -> Encoding
9597instance ToValue Int16 'PGInt2 where
9698 toValue _ = Encoder.int2_int16
9799instance ToValue Int32 'PGInt4 where
@@ -113,7 +115,7 @@ instance ToValue Text 'PGText where
113115instance ToValue Lazy.Text 'PGText where
114116 toValue _ = Encoder.text_lazy
115117instance ToValue Char ('PGChar 1) where
116− toValue _ = Encoder.char
118+ toValue _ = Encoder.char_utf8
117119instance ToValue Scientific 'PGNumeric where
118120 toValue _ = Encoder.numeric
119121instance ToValue UUID 'PGUuid where
@@ -141,5 +143,5 @@ instance ToValues '[] '[] where toValues _ _ = []
141143instance (ToValue x pg, ToValues xs pgs)
142144 => ToValues (x ': xs) (pg ': pgs) where
143145 toValues _ (Identity x :& xs)
144− = Encoder.run (toValue (proxy# :: Proxy# pg)) x
146+ = Encoder.encodingBytes ((toValue (proxy# :: Proxy# pg)) x)
145147 : toValues (proxy# :: Proxy# pgs) xs
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+31−24
@@ -1,5 +1,7 @@
1+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
12{-# LANGUAGE
23 DataKinds
4+ , FunctionalDependencies
35 , PolyKinds
46 , DeriveFunctor
57 , FlexibleContexts
@@ -35,8 +37,8 @@ import Squeel.PostgreSQL.Schema
3537newtype Connection db = Connection { unConnection :: LibPQ.Connection }
3638
3739newtype PQ
38− (db0 :: [(Symbol,[(Symbol,NullityType)])])
39− (db1 :: [(Symbol,[(Symbol,NullityType)])])
40+ (db0 :: [(Symbol,[(Symbol,ColumnType)])])
41+ (db1 :: [(Symbol,[(Symbol,ColumnType)])])
4042 (m :: * -> *)
4143 (x :: *) =
4244 PQ { runPQ :: Connection db0 -> m (x, Connection db1) }
@@ -64,24 +66,24 @@ class MonadPQ pq where
6466
6567 pqExec
6668 :: MonadBase IO io
67− => Statement '[] db0 db1 xs
68− -> pq db0 db1 io (Maybe (Result xs))
69+ => Statement '[] '[] db0 db1
70+ -> pq db0 db1 io (Maybe (Result '[]))
6971
7072 pqExecParams
7173 :: (MonadBase IO io, ToOids ps, ToValues xs ps)
72− => Statement ps db0 db1 ys
74+ => Statement ps ys db0 db1
7375 -> Rec Identity xs
7476 -> pq db0 db1 io (Maybe (Result ys))
7577
7678 pqPrepare
7779 :: (MonadBase IO io, ToOids ps)
7880 => ByteString
79− -> Statement ps db0 db1 xs
80− -> pq db0 db1 io (Maybe (Result []), PreparedStatement ps db0 db1 xs)
81+ -> Statement ps xs db0 db1
82+ -> pq db0 db1 io (Maybe (Result []), PreparedStatement ps xs db0 db1)
8183
8284 pqExecPrepared
8385 :: (MonadBase IO io, ToValues xs ps)
84− => PreparedStatement ps db0 db1 ys
86+ => PreparedStatement ps ys db0 db1
8587 -> Rec Identity xs
8688 -> pq db0 db1 io (Maybe (Result ys))
8789
@@ -100,7 +102,7 @@ instance MonadPQ PQ where
100102 result <- liftBase $ LibPQ.exec conn q
101103 return (Result <$> result, Connection conn)
102104
103− pqExecParams (UnsafeStatement q :: Statement ps db0 db1 ys) params =
105+ pqExecParams (UnsafeStatement q :: Statement ps ys db0 db1) params =
104106 PQ $ \ (Connection conn) -> do
105107 let
106108 params' =
@@ -113,7 +115,7 @@ instance MonadPQ PQ where
113115 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
114116 return (Result <$> result, Connection conn)
115117
116− pqPrepare statementName (UnsafeStatement q :: Statement ps db0 db1 ys) =
118+ pqPrepare statementName (UnsafeStatement q :: Statement ps ys db0 db1) =
117119 PQ $ \ (Connection conn) -> do
118120 result <- liftBase $
119121 LibPQ.prepare conn statementName q (Just (toOids (proxy# :: Proxy# ps)))
@@ -122,7 +124,7 @@ instance MonadPQ PQ where
122124 , UnsafePreparedStatement statementName
123125 ) , Connection conn )
124126
125− pqExecPrepared (q :: PreparedStatement ps db0 db1 ys) params =
127+ pqExecPrepared (q :: PreparedStatement ps ys db0 db1) params =
126128 PQ $ \ (Connection conn) -> do
127129 let
128130 params' =
@@ -181,27 +183,32 @@ newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
181183
182184newtype ColumnNumber cs c = ColumnNumber { unColumnNumber :: LibPQ.Column }
183185
184−colNum0 :: ColumnNumber (c0:cs) c0
185−colNum0 = ColumnNumber 0
186+class KnownNat n => HasColumnNumber (n :: Nat) columns column
187+ | n columns -> column where
188+ colNum :: Proxy# n -> ColumnNumber columns column
189+ colNum p = ColumnNumber . fromIntegral $ natVal' p
190+instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1
191+instance {-# OVERLAPPABLE #-}
192+ (KnownNat n, HasColumnNumber (n-1) columns column)
193+ => HasColumnNumber n (column' : columns) column
186194
195+colNum0 :: ColumnNumber (c0:cs) c0
196+colNum0 = colNum (proxy# :: Proxy# 0)
187197colNum1 :: ColumnNumber (c0:c1:cs) c1
188−colNum1 = ColumnNumber 1
189−
198+colNum1 = colNum (proxy# :: Proxy# 1)
190199colNum2 :: ColumnNumber (c0:c1:c2:cs) c2
191−colNum2 = ColumnNumber 2
192−
200+colNum2 = colNum (proxy# :: Proxy# 2)
193201colNum3 :: ColumnNumber (c0:c1:c2:c3:cs) c3
194−colNum3 = ColumnNumber 3
195−
202+colNum3 = colNum (proxy# :: Proxy# 3)
196203colNum4 :: ColumnNumber (c0:c1:c2:c3:c4:cs) c4
197−colNum4 = ColumnNumber 4
204+colNum4 = colNum (proxy# :: Proxy# 4)
198205
199206getvalue
200207 :: (FromValue x y, MonadBase IO io)
201− => Proxy# x
202− -> Result xs
208+ => Result xs
203209 -> RowNumber
204210 -> ColumnNumber xs x
205211 -> io (Maybe (Either Text y))
206−getvalue proxy (Result result) (RowNumber r) (ColumnNumber c) = liftBase $
207− fmap (fmap (decodeValue proxy)) (LibPQ.getvalue result r c)
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)
squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+15−83
@@ -21,13 +21,12 @@ module Squeel.PostgreSQL.Schema
2121 , (:::)
2222 , Alias (Alias)
2323 , Aliased (As)
24− , KnownPGType (..)
25− , KnownColumns (..)
2624 , renderAliased
2725 , NullityType (..)
28− , NullifyType
26+ , NullifyColumn
2927 , NullifyColumns
3028 , NullifyTable
29+ , ColumnType (..)
3130 , module GHC.OverloadedLabels
3231 , module GHC.TypeLits
3332 ) where
@@ -68,6 +67,13 @@ data PGType
6867 | PGJsonb
6968
7069class ToOid pg where toOid :: Proxy# pg -> LibPQ.Oid
70+--staticTypeInfo
71+instance ToOid ('NotNull 'PGBool) where toOid _ = LibPQ.Oid 16
72+instance ToOid ('NotNull 'PGBytea) where toOid _ = LibPQ.Oid 17
73+instance ToOid ('NotNull 'PGInt8) where toOid _ = LibPQ.Oid 20
74+instance ToOid ('NotNull 'PGInt2) where toOid _ = LibPQ.Oid 21
75+instance ToOid ('NotNull 'PGInt4) where toOid _ = LibPQ.Oid 23
76+instance ToOid ('NotNull 'PGText) where toOid _ = LibPQ.Oid 26
7177class ToOids pgs where toOids :: Proxy# pgs -> [LibPQ.Oid]
7278instance ToOids '[] where toOids _ = []
7379instance (ToOid pg, ToOids pgs) => ToOids (pg ': pgs) where
@@ -106,92 +112,18 @@ renderAliased
106112renderAliased render (expression `As` Alias alias) =
107113 render expression <> " AS " <> fromString (symbolVal' alias)
108114
109−class KnownPGType (ty :: PGType) where
110− renderPGType :: Proxy# ty -> ByteString
111−instance KnownPGType 'PGBool where renderPGType _ = "bool"
112−instance KnownPGType 'PGInt2 where renderPGType _ = "int2"
113−instance KnownPGType 'PGInt4 where renderPGType _ = "int4"
114−instance KnownPGType 'PGInt8 where renderPGType _ = "int8"
115−instance KnownPGType 'PGNumeric where renderPGType _ = "numeric"
116−instance KnownPGType 'PGFloat4 where renderPGType _ = "float4"
117−instance KnownPGType 'PGFloat8 where renderPGType _ = "float8"
118−instance KnownPGType 'PGSerial2 where renderPGType _ = "serial2"
119−instance KnownPGType 'PGSerial4 where renderPGType _ = "serial4"
120−instance KnownPGType 'PGSerial8 where renderPGType _ = "serial8"
121−instance KnownPGType 'PGMoney where renderPGType _ = "money"
122−instance KnownNat n => KnownPGType ('PGChar n) where
123− renderPGType _ = "char("
124− <> fromString (show (natVal' (proxy# :: Proxy# n)))
125− <> ")"
126−instance KnownNat n => KnownPGType ('PGVarChar n) where
127− renderPGType _ = "varchar("
128− <> fromString (show (natVal' (proxy# :: Proxy# n)))
129− <> ")"
130−instance KnownPGType 'PGText where renderPGType _ = "text"
131−instance KnownPGType 'PGBytea where renderPGType _ = "bytea"
132−instance KnownPGType 'PGTimestamp where renderPGType _ = "timestamp"
133−instance KnownPGType 'PGTimestampTZ where renderPGType _ = "timestampTZ"
134−instance KnownPGType 'PGDate where renderPGType _ = "date"
135−instance KnownPGType 'PGTime where renderPGType _ = "time"
136−instance KnownPGType 'PGTimeTZ where renderPGType _ = "timeTZ"
137−instance KnownPGType 'PGInterval where renderPGType _ = "interval"
138−instance KnownPGType 'PGUuid where renderPGType _ = "uuid"
139−instance KnownPGType 'PGJson where renderPGType _ = "json"
140−instance KnownPGType 'PGJsonb where renderPGType _ = "jsonb"
141−
142−class KnownColumns (columns :: [(Symbol,NullityType)]) where
143− renderColumns :: Proxy# columns -> ByteString
144−instance
145− ( KnownSymbol column
146− , KnownPGType ty
147− ) => KnownColumns '[column ::: 'NotNull ty] where
148− renderColumns _ =
149− fromString (symbolVal' (proxy# :: Proxy# column))
150− <> " "
151− <> renderPGType (proxy# :: Proxy# ty)
152− <> " NOT NULL"
153−instance
154− ( KnownSymbol column
155− , KnownPGType ty
156− ) => KnownColumns '[column ::: 'Null ty] where
157− renderColumns _ =
158− fromString (symbolVal' (proxy# :: Proxy# column))
159− <> " "
160− <> renderPGType (proxy# :: Proxy# ty)
161− <> " NULL"
162−instance
163− ( KnownSymbol column
164− , KnownPGType ty
165− , KnownColumns (columnsHead ': columnsTail)
166− ) => KnownColumns ((column ::: 'NotNull ty) ': columnsHead ': columnsTail) where
167− renderColumns _ =
168− fromString (symbolVal' (proxy# :: Proxy# column))
169− <> " "
170− <> renderPGType (proxy# :: Proxy# ty)
171− <> " NOT NULL, "
172− <> renderColumns (proxy# :: Proxy# (columnsHead ': columnsTail))
173−instance
174− ( KnownSymbol column
175− , KnownPGType ty
176− , KnownColumns (columnsHead ': columnsTail)
177− ) => KnownColumns ((column ::: 'Null ty) ': columnsHead ': columnsTail) where
178− renderColumns _ =
179− fromString (symbolVal' (proxy# :: Proxy# column))
180− <> " "
181− <> renderPGType (proxy# :: Proxy# ty)
182− <> " NULL, "
183− <> renderColumns (proxy# :: Proxy# (columnsHead ': columnsTail))
184−
185115data NullityType = Null PGType | NotNull PGType
186116
187−type family NullifyType nullty where
188− NullifyType ('Null ty) = 'Null ty
189− NullifyType ('NotNull ty) = 'Null ty
117+data ColumnType = Optional NullityType | Required NullityType
118+
119+type family NullifyColumn (column :: ColumnType) where
120+ NullifyColumn (optionality ('Null ty)) = optionality ('Null ty)
121+ NullifyColumn (optionality ('NotNull ty)) = optionality ('Null ty)
190122
191123type family NullifyColumns columns where
192124 NullifyColumns '[] = '[]
193125 NullifyColumns ((column ::: ty) ': columns) =
194− (column ::: (NullifyType ty)) ': (NullifyColumns columns)
126+ (column ::: NullifyColumn ty) ': (NullifyColumns columns)
195127
196128type family NullifyTable table where
197129 NullifyTable (table ::: columns) = table ::: NullifyColumns columns
squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+219−144
@@ -14,6 +14,7 @@
1414
1515module Squeel.PostgreSQL.Statement where
1616
17+import Control.Category
1718import Data.Boolean
1819import Data.ByteString (ByteString)
1920import Data.Maybe
@@ -24,16 +25,22 @@ import Data.Vinyl.Functor
2425import GHC.Exts
2526import GHC.OverloadedLabels
2627import GHC.TypeLits
28+import Prelude hiding (id,(.))
2729
2830import qualified Data.ByteString as ByteString
2931
3032import Squeel.PostgreSQL.Schema
3133
34+{-----------------------------------------
35+column expressions
36+-----------------------------------------}
37+
3238newtype Expression
33− (params :: [NullityType])
34− (tables :: [(Symbol,[(Symbol,NullityType)])])
35− (ty :: NullityType)
36− = UnsafeExpression { renderExpression :: ByteString }
39+ (params :: [ColumnType])
40+ (tables :: [(Symbol,[(Symbol,ColumnType)])])
41+ (ty :: ColumnType)
42+ = UnsafeExpression { renderExpression :: ByteString }
43+ deriving (Show,Eq)
3744
3845class KnownNat n => HasParameter (n :: Nat) params ty | n params -> ty where
3946 param :: Proxy# n -> Expression params tables ty
@@ -58,7 +65,7 @@ class KnownSymbol column => HasColumn column columns ty
5865 getColumn :: Proxy# column -> Expression params '[table ::: columns] ty
5966 getColumn column = UnsafeExpression $ fromString $ symbolVal' column
6067instance {-# OVERLAPPING #-} KnownSymbol column
61− => HasColumn column ((column ::: ty) ': tys) ty
68+ => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)
6269instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
6370 => HasColumn column (ty' ': table) ty
6471
@@ -66,14 +73,31 @@ instance (HasColumn column columns ty, tables ~ '[table ::: columns])
6673 => IsLabel column (Expression params tables ty) where
6774 fromLabel = getColumn
6875
69−(.&.)
76+(&.)
7077 :: (HasTable table tables columns, HasColumn column columns ty)
7178 => Alias table -> Alias column -> Expression params tables ty
72−Alias table .&. Alias column = UnsafeExpression $
79+Alias table &. Alias column = UnsafeExpression $
7380 fromString (symbolVal' table)
7481 <> "." <>
7582 fromString (symbolVal' column)
7683
84+def :: Expression params '[] ('Optional (nullity ty))
85+def = UnsafeExpression "DEFAULT"
86+
87+null :: Expression params tables (optionality ('Null ty))
88+null = UnsafeExpression "NULL"
89+
90+coalesce
91+ :: [Expression params tables ('Required ('Null x))]
92+ -> Expression params tables ('Required ('NotNull x))
93+ -> Expression params tables ('Required ('NotNull x))
94+coalesce nulls isn'tNull = UnsafeExpression $ mconcat
95+ [ "COALESCE("
96+ , ByteString.intercalate ", " $ map renderExpression nulls
97+ , ", ", renderExpression isn'tNull
98+ , ")"
99+ ]
100+
77101unsafeBinaryOp
78102 :: ByteString
79103 -> Expression params tables ty0
@@ -96,7 +120,7 @@ unsafeFunction
96120unsafeFunction fn x = UnsafeExpression $ mconcat
97121 [fn, "(", renderExpression x, ")"]
98122
99−instance PGNum ty => Num (Expression params tables (nullity ty)) where
123+instance PGNum ty => Num (Expression params tables ('Required (nullity ty))) where
100124 (+) = unsafeBinaryOp "+"
101125 (-) = unsafeBinaryOp "-"
102126 (*) = unsafeBinaryOp "*"
@@ -104,7 +128,7 @@ instance PGNum ty => Num (Expression params tables (nullity ty)) where
104128 signum = unsafeFunction "sign"
105129 fromInteger = UnsafeExpression . fromString . show
106130
107−instance IsString (Expression params tables (nullity 'PGText)) where
131+instance IsString (Expression params tables ('Required (nullity 'PGText))) where
108132 fromString str = UnsafeExpression $
109133 "E\'" <> fromString (escape =<< str) <> "\'"
110134 where
@@ -119,7 +143,7 @@ instance IsString (Expression params tables (nullity 'PGText)) where
119143 '\\' -> "\\\\"
120144 c -> [c]
121145
122−instance Boolean (Expression params tables ('NotNull 'PGBool)) where
146+instance Boolean (Expression params tables ('Required ('NotNull 'PGBool))) where
123147 true = UnsafeExpression "TRUE"
124148 false = UnsafeExpression "FALSE"
125149 notB = unsafeUnaryOp "NOT"
@@ -127,21 +151,10 @@ instance Boolean (Expression params tables ('NotNull 'PGBool)) where
127151 (||*) = unsafeBinaryOp "OR"
128152
129153type instance BooleanOf (Expression params tables ty) =
130− Expression params tables ('NotNull 'PGBool)
131−
132−coalesce
133− :: [Expression params tables ('Null x)]
134− -> Expression params tables ('NotNull x)
135− -> Expression params tables ('NotNull x)
136−coalesce nulls notNull = UnsafeExpression $ mconcat
137− [ "COALESCE("
138− , ByteString.intercalate ", " $ map renderExpression nulls
139− , ", ", renderExpression notNull
140− , ")"
141− ]
154+ Expression params tables ('Required ('NotNull 'PGBool))
142155
143156caseWhenThenElse
144− :: [(Expression params tables ('NotNull 'PGBool), Expression params tables ty)]
157+ :: [(Expression params tables ('Required ('NotNull 'PGBool)), Expression params tables ty)]
145158 -> Expression params tables ty
146159 -> Expression params tables ty
147160caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
@@ -160,115 +173,149 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
160173instance IfB (Expression params tables ty) where
161174 ifB if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
162175
163−instance EqB (Expression params tables ty) where
176+instance EqB (Expression params tables (optionality ('NotNull ty))) where
164177 (==*) = unsafeBinaryOp "="
165178 (/=*) = unsafeBinaryOp "<>"
166179
167−instance OrdB (Expression params tables ty) where
180+instance OrdB (Expression params tables (optionality ('NotNull ty))) where
168181 (>*) = unsafeBinaryOp ">"
169182 (>=*) = unsafeBinaryOp ">="
170183 (<*) = unsafeBinaryOp "<"
171184 (<=*) = unsafeBinaryOp "<="
172185
186+{-----------------------------------------
187+table expressions
188+-----------------------------------------}
189+
173190newtype TableExpression
174− (params :: [NullityType])
175− (schema :: [(Symbol,[(Symbol,NullityType)])])
176− (columns :: [(Symbol,NullityType)])
191+ (params :: [ColumnType])
192+ (schema :: [(Symbol,[(Symbol,ColumnType)])])
193+ (columns :: [(Symbol,ColumnType)])
177194 = UnsafeTableExpression { renderTableExpression :: ByteString }
195+ deriving (Show,Eq)
196+
197+class KnownSymbol table => HasTable table tables columns
198+ | table tables -> columns where
199+ getTable :: Proxy# table -> TableExpression params tables columns
200+ getTable table = UnsafeTableExpression $ fromString $ symbolVal' table
201+instance {-# OVERLAPPING #-} KnownSymbol table
202+ => HasTable table ((table ::: columns) ': tables) columns
203+instance {-# OVERLAPPABLE #-}
204+ (KnownSymbol table, HasTable table schema columns)
205+ => HasTable table (table' ': schema) columns
206+
207+instance HasTable table schema columns
208+ => IsLabel table (TableExpression params schema columns) where
209+ fromLabel = getTable
210+
211+{-----------------------------------------
212+statements
213+-----------------------------------------}
214+
215+newtype Statement
216+ (params :: [ColumnType])
217+ (columns :: [(Symbol,ColumnType)])
218+ (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
219+ (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
220+ = UnsafeStatement { renderStatement :: ByteString }
221+ deriving (Show,Eq)
222+
223+instance Category (Statement '[] '[]) where
224+ id = UnsafeStatement ";"
225+ statement2 . statement1 = UnsafeStatement $
226+ renderStatement statement1 <> " " <> renderStatement statement2
227+
228+newtype PreparedStatement
229+ (params :: [ColumnType])
230+ (columns :: [(Symbol,ColumnType)])
231+ (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
232+ (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
233+ = UnsafePreparedStatement { renderPreparedStatement :: ByteString }
234+ deriving (Show,Eq)
178235
179−data JoinExpression params schema tables where
236+{-----------------------------------------
237+SELECT statements
238+-----------------------------------------}
239+
240+data Join params schema tables where
180241 Table
181242 :: Aliased (TableExpression params schema) table
182− -> JoinExpression params schema '[table]
243+ -> Join params schema '[table]
183244 Subselect
184245 :: Aliased (Selection params schema) table
185− -> JoinExpression params schema '[table]
246+ -> Join params schema '[table]
186247 Cross
187248 :: Aliased (TableExpression params schema) table
188− -> JoinExpression params schema tables
189− -> JoinExpression params schema (table ': tables)
249+ -> Join params schema tables
250+ -> Join params schema (table ': tables)
190251 Inner
191252 :: Aliased (TableExpression params schema) table
192− -> Expression params (table ': tables) ('NotNull 'PGBool)
193− -> JoinExpression params schema tables
194− -> JoinExpression params schema (table ': tables)
253+ -> Expression params (table ': tables) ('Required ('NotNull 'PGBool))
254+ -> Join params schema tables
255+ -> Join params schema (table ': tables)
195256 LeftOuter
196257 :: Aliased (TableExpression params schema) right
197− -> Expression params '[left,right] ('NotNull 'PGBool)
198− -> JoinExpression params schema (tables)
199− -> JoinExpression params schema (NullifyTable right ': left ': tables)
258+ -> Expression params '[left,right] ('Required ('NotNull 'PGBool))
259+ -> Join params schema (tables)
260+ -> Join params schema (NullifyTable right ': left ': tables)
200261 RightOuter
201262 :: Aliased (TableExpression params schema) right
202− -> Expression params '[left,right] ('NotNull 'PGBool)
203− -> JoinExpression params schema (left : tables)
204− -> JoinExpression params schema (right ': NullifyTable left ': tables)
263+ -> Expression params '[left,right] ('Required ('NotNull 'PGBool))
264+ -> Join params schema (left : tables)
265+ -> Join params schema (right ': NullifyTable left ': tables)
205266 FullOuter
206267 :: Aliased (TableExpression params schema) right
207− -> Expression params '[left,right] ('NotNull 'PGBool)
208− -> JoinExpression params schema (left : tables)
209− -> JoinExpression params schema
268+ -> Expression params '[left,right] ('Required ('NotNull 'PGBool))
269+ -> Join params schema (left : tables)
270+ -> Join params schema
210271 (NullifyTable right ': NullifyTable left ': tables)
211272
212−renderJoinExpression :: JoinExpression params schema tables -> ByteString
213−renderJoinExpression = \case
273+renderJoin :: Join params schema tables -> ByteString
274+renderJoin = \case
214275 Table table -> renderAliased renderTableExpression table
215276 Subselect selection -> "SELECT " <> renderAliased renderSelection selection
216277 Cross table tables -> mconcat
217− [ renderJoinExpression tables
278+ [ renderJoin tables
218279 , " CROSS JOIN "
219280 , renderAliased renderTableExpression table
220281 ]
221282 Inner table on tables -> mconcat
222− [ renderJoinExpression tables
283+ [ renderJoin tables
223284 , " INNER JOIN "
224285 , renderAliased renderTableExpression table
225286 , " ON "
226287 , renderExpression on
227288 ]
228289 LeftOuter table on tables -> mconcat
229− [ renderJoinExpression tables
290+ [ renderJoin tables
230291 , " LEFT OUTER JOIN "
231292 , renderAliased renderTableExpression table
232293 , " ON "
233294 , renderExpression on
234295 ]
235296 RightOuter table on tables -> mconcat
236− [ renderJoinExpression tables
297+ [ renderJoin tables
237298 , " RIGHT OUTER JOIN "
238299 , renderAliased renderTableExpression table
239300 , " ON "
240301 , renderExpression on
241302 ]
242303 FullOuter table on tables -> mconcat
243− [ renderJoinExpression tables
304+ [ renderJoin tables
244305 , " FULL OUTER JOIN "
245306 , renderAliased renderTableExpression table
246307 , " ON "
247308 , renderExpression on
248309 ]
249310
250−class KnownSymbol table => HasTable table tables columns
251− | table tables -> columns where
252− getTable :: Proxy# table -> TableExpression params tables columns
253− getTable table = UnsafeTableExpression $ fromString $ symbolVal' table
254−instance {-# OVERLAPPING #-} KnownSymbol table
255− => HasTable table ((table ::: columns) ': tables) columns
256−instance {-# OVERLAPPABLE #-}
257− (KnownSymbol table, HasTable table schema columns)
258− => HasTable table (table' ': schema) columns
259−
260311instance HasTable table schema columns
261− => IsLabel table (TableExpression params schema columns) where
262− fromLabel = getTable
263−
264−instance HasTable table schema columns
265− => IsLabel table (JoinExpression params schema '[table ::: columns]) where
312+ => IsLabel table (Join params schema '[table ::: columns]) where
266313 fromLabel p = Table $ fromLabel p
267314
268315data Clauses params tables = Clauses
269− { whereClause :: Maybe (Expression params tables ('NotNull 'PGBool))
270− , limitClause :: Maybe (Expression params '[] ('NotNull 'PGInt8))
271− , offsetClause :: Maybe (Expression params '[] ('NotNull 'PGInt8))
316+ { whereClause :: Maybe (Expression params tables ('Required ('NotNull 'PGBool)))
317+ , limitClause :: Maybe (Expression params '[] ('Required ('NotNull 'PGInt8)))
318+ , offsetClause :: Maybe (Expression params '[] ('Required ('NotNull 'PGInt8)))
272319 }
273320
274321instance Monoid (Clauses params tables) where
@@ -291,124 +338,108 @@ instance Monoid (Clauses params tables) where
291338 (Just o1,Just o2) -> Just (o1 + o2)
292339 }
293340
294−data FromExpression
295− (params :: [NullityType])
296− (schema :: [(Symbol,[(Symbol,NullityType)])])
297− (tables :: [(Symbol,[(Symbol,NullityType)])])
298− = FromExpression
299− { joinExpression :: JoinExpression params schema tables
300− , clauses :: Clauses params tables
341+data From
342+ (params :: [ColumnType])
343+ (schema :: [(Symbol,[(Symbol,ColumnType)])])
344+ (tables :: [(Symbol,[(Symbol,ColumnType)])])
345+ = From
346+ { fromJoin :: Join params schema tables
347+ , fromClauses :: Clauses params tables
301348 }
302349
303350join
304− :: JoinExpression params schema tables
305− -> FromExpression params schema tables
306−join tref = FromExpression tref mempty
351+ :: Join params schema tables
352+ -> From params schema tables
353+join tables = From tables mempty
307354
308−renderFromExpression :: FromExpression params schema tables -> ByteString
309−renderFromExpression (FromExpression tref (Clauses wh lim off))= mconcat
310− [ renderJoinExpression tref
355+renderFrom :: From params schema tables -> ByteString
356+renderFrom (From tref (Clauses wh lim off))= mconcat
357+ [ renderJoin tref
311358 , maybe "" ((" WHERE " <>) . renderExpression) wh
312359 , maybe "" ((" LIMIT " <>) . renderExpression) lim
313360 , maybe "" ((" OFFSET " <>) . renderExpression) off
314361 ]
315362
316363instance (HasTable table schema columns, table ~ table')
317− => IsLabel table (FromExpression params schema '[table' ::: columns]) where
318− fromLabel p = FromExpression (fromLabel p) mempty
364+ => IsLabel table (From params schema '[table' ::: columns]) where
365+ fromLabel p = From (fromLabel p) mempty
319366
320367where_
321− :: Expression params tables ('NotNull 'PGBool)
322− -> FromExpression params schema tables
323− -> FromExpression params schema tables
324−where_ wh (FromExpression tabs clauses1) = FromExpression tabs
325− (clauses1 <> Clauses (Just wh) Nothing Nothing)
368+ :: Expression params tables ('Required ('NotNull 'PGBool))
369+ -> From params schema tables
370+ -> From params schema tables
371+where_ wh (From tabs fromClauses1) = From tabs
372+ (fromClauses1 <> Clauses (Just wh) Nothing Nothing)
326373
327374limit
328− :: Expression params '[] ('NotNull 'PGInt8)
329− -> FromExpression params schema tables
330− -> FromExpression params schema tables
331−limit lim (FromExpression tabs clauses1) = FromExpression tabs
332− (clauses1 <> Clauses Nothing (Just lim) Nothing)
375+ :: Expression params '[] ('Required ('NotNull 'PGInt8))
376+ -> From params schema tables
377+ -> From params schema tables
378+limit lim (From tabs fromClauses1) = From tabs
379+ (fromClauses1 <> Clauses Nothing (Just lim) Nothing)
333380
334381offset
335− :: Expression params '[] ('NotNull 'PGInt8)
336− -> FromExpression params schema tables
337− -> FromExpression params schema tables
338−offset off (FromExpression tabs clauses1) = FromExpression tabs
339− (clauses1 <> Clauses Nothing Nothing (Just off))
382+ :: Expression params '[] ('Required ('NotNull 'PGInt8))
383+ -> From params schema tables
384+ -> From params schema tables
385+offset off (From tabs fromClauses1) = From tabs
386+ (fromClauses1 <> Clauses Nothing Nothing (Just off))
340387
341388newtype Selection
342− (params :: [NullityType])
343− (schema :: [(Symbol,[(Symbol,NullityType)])])
344− (columns :: [(Symbol,NullityType)])
389+ (params :: [ColumnType])
390+ (schema :: [(Symbol,[(Symbol,ColumnType)])])
391+ (columns :: [(Symbol,ColumnType)])
345392 = UnsafeSelection { renderSelection :: ByteString }
393+ deriving (Show,Eq)
346394
347395starFrom
348396 :: tables ~ '[table ::: columns]
349− => FromExpression params schema tables
397+ => From params schema tables
350398 -> Selection params schema columns
351−starFrom tabs = UnsafeSelection $ "* FROM " <> renderFromExpression tabs
399+starFrom tabs = UnsafeSelection $ "* FROM " <> renderFrom tabs
352400
353401dotStarFrom
354402 :: HasTable table tables columns
355403 => Alias table
356− -> FromExpression params schema tables
404+ -> From params schema tables
357405 -> Selection params schema columns
358406Alias tab `dotStarFrom` tabs = UnsafeSelection $
359− fromString (symbolVal' tab) <> ".* FROM " <> renderFromExpression tabs
407+ fromString (symbolVal' tab) <> ".* FROM " <> renderFrom tabs
360408
361409from
362410 :: Rec (Aliased (Expression params tables)) columns
363− -> FromExpression params schema tables
411+ -> From params schema tables
364412 -> Selection params schema columns
365413list `from` tabs = UnsafeSelection $
366− renderList list <> " FROM " <> renderFromExpression tabs
414+ renderList list <> " FROM " <> renderFrom tabs
367415 where
368416 renderList
369417 = ByteString.intercalate ", "
370418 . recordToList
371419 . rmap (Const . renderAliased renderExpression)
372420
373−newtype Statement
374− (params :: [NullityType])
375− (schema0 :: [(Symbol,[(Symbol,NullityType)])])
376− (schema1 :: [(Symbol,[(Symbol,NullityType)])])
377− (columns :: [(Symbol,NullityType)])
378− = UnsafeStatement { renderStatement :: ByteString }
379−
380−(.>>.)
381− :: Statement params schema0 schema1 '[]
382− -> Statement params schema1 schema2 results
383− -> Statement params schema0 schema2 results
384−statement1 .>>. statement2 = UnsafeStatement $
385− renderStatement statement1 <> " " <> renderStatement statement2
386−
387−newtype PreparedStatement
388− (params :: [NullityType])
389− (schema0 :: [(Symbol,[(Symbol,NullityType)])])
390− (schema1 :: [(Symbol,[(Symbol,NullityType)])])
391− (columns :: [(Symbol,NullityType)])
392− = UnsafePreparedStatement { renderPreparedStatement :: ByteString }
393−
394421select
395422 :: Selection params schema columns
396− -> Statement params schema schema columns
423+ -> Statement params columns schema schema
397424select = UnsafeStatement . ("SELECT " <>) . (<> ";") . renderSelection
398425
399426subselect
400427 :: Aliased (Selection params schema) table
401− -> FromExpression params schema '[table]
402−subselect selection = FromExpression
403− { joinExpression = Subselect selection
404− , clauses = mempty
428+ -> From params schema '[table]
429+subselect selection = From
430+ { fromJoin = Subselect selection
431+ , fromClauses = mempty
405432 }
406433
434+{-----------------------------------------
435+INSERT statements
436+-----------------------------------------}
437+
407438insertInto
408439 :: HasTable table schema columns
409440 => Alias table
410441 -> Rec (Aliased (Expression params '[])) columns
411− -> Statement params schema schema '[]
442+ -> Statement params '[] schema schema
412443insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
413444 <> fromString (symbolVal' table)
414445 <> " (" <> ByteString.intercalate ", " aliases
@@ -423,22 +454,62 @@ insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
423454 (\ (expression `As` _) -> Const (renderExpression expression))
424455 expressions
425456
457+{-----------------------------------------
458+CREATE statements
459+-----------------------------------------}
460+
461+newtype TypeExpression (ty :: ColumnType)
462+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }
463+ deriving (Show,Eq)
464+
465+int2 :: TypeExpression ('Required ('Null 'PGInt2))
466+int2 = UnsafeTypeExpression "int2"
467+int4 :: TypeExpression ('Required ('Null 'PGInt4))
468+int4 = UnsafeTypeExpression "int4"
469+int8 :: TypeExpression ('Required ('Null 'PGInt8))
470+int8 = UnsafeTypeExpression "int8"
471+bool :: TypeExpression ('Required ('Null 'PGBool))
472+bool = UnsafeTypeExpression "bool"
473+text :: TypeExpression ('Required ('Null 'PGText))
474+text = UnsafeTypeExpression "text"
475+notNull
476+ :: TypeExpression ('Required ('Null ty))
477+ -> TypeExpression ('Required ('NotNull ty))
478+notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <> " NOT NULL"
479+default_
480+ :: Expression '[] '[] ('Required ty)
481+ -> TypeExpression ('Required ty)
482+ -> TypeExpression ('Optional ty)
483+default_ x ty = UnsafeTypeExpression $
484+ renderTypeExpression ty <> " DEFAULT " <> renderExpression x
485+serial :: TypeExpression ('Optional ('NotNull 'PGInt4))
486+serial = UnsafeTypeExpression "serial"
487+
426488createTable
427− :: (KnownSymbol table, KnownColumns columns)
428− => Alias table
429− -> Proxy# columns
430− -> Statement '[] schema ((table ::: columns) ': schema) '[]
489+ :: KnownSymbol table
490+ => Alias table
491+ -> Rec (Aliased TypeExpression) columns
492+ -> Statement '[] '[] schema ((table ::: columns) ': schema)
431493createTable (Alias table) columns = UnsafeStatement $ mconcat
432494 [ "CREATE TABLE "
433495 , fromString $ symbolVal' table
434496 , " ("
435− , renderColumns columns
497+ , ByteString.intercalate ", " . recordToList $
498+ rmap (Const . renderColumn) columns
436499 , ");"
437500 ]
501+ where
502+ renderColumn :: Aliased TypeExpression x -> ByteString
503+ renderColumn (ty `As` Alias column) =
504+ fromString (symbolVal' column) <> " " <> renderTypeExpression ty
505+
506+{-----------------------------------------
507+DROP statements
508+-----------------------------------------}
438509
439510class KnownSymbol table => DropTable table schema0 schema1
440511 | table schema0 -> schema1 where
441− dropTable :: Alias table -> Statement '[] schema0 schema1 '[]
512+ dropTable :: Alias table -> Statement '[] '[] schema0 schema1
442513 dropTable (Alias table) = UnsafeStatement $
443514 "DROP TABLE " <> fromString (symbolVal' table) <> ";"
444515instance {-# OVERLAPPING #-}
@@ -448,6 +519,10 @@ instance {-# OVERLAPPABLE #-}
448519 (KnownSymbol table, DropTable table schema0 schema1)
449520 => DropTable table (tabCols ': schema0) (tabCols ': schema1)
450521
522+{-----------------------------------------
523+UPDATE statements
524+-----------------------------------------}
525+
451526set :: g x -> (Maybe `Compose` g) x
452527set = Compose . Just
453528
@@ -458,8 +533,8 @@ update
458533 :: HasTable table schema columns
459534 => Alias table
460535 -> Rec (Aliased (Maybe `Compose` Expression params '[table ::: columns])) columns
461− -> Expression params '[table ::: columns] ('NotNull 'PGBool)
462− -> Statement params schema schema '[]
536+ -> Expression params '[table ::: columns] ('Required ('NotNull 'PGBool))
537+ -> Statement params '[] schema schema
463538update (Alias table) columns where' = UnsafeStatement $ mconcat
464539 [ "UPDATE "
465540 , fromString $ symbolVal' table
squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+58−44
@@ -11,7 +11,6 @@ module Squeel.PostgreSQL.StatementSpec where
1111import Data.Boolean
1212import Data.Function
1313import Data.Vinyl
14−import GHC.Exts
1514import Test.Hspec
1615
1716import Squeel.PostgreSQL.Statement
@@ -23,7 +22,7 @@ spec = do
2322 query `shouldRenderAs` str = renderStatement query `shouldBe` str
2423 it "correctly renders a simple SELECT query" $ do
2524 let
26− statement :: Statement '[] Tables Tables SumAndCol1
25+ statement :: Statement '[] SumAndCol1 Tables Tables
2726 statement = select $
2827 ((#col1 + #col2) `As` #sum :& #col1 :& RNil)
2928 `from` (#table1 & where_ true)
@@ -31,7 +30,7 @@ spec = do
3130 "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE TRUE;"
3231 it "combines WHEREs using AND" $ do
3332 let
34− statement :: Statement '[] Tables Tables SumAndCol1
33+ statement :: Statement '[] SumAndCol1 Tables Tables
3534 statement = select $
3635 ((#col1 + #col2) `As` #sum :& #col1 :& RNil)
3736 `from` (#table1 & where_ true & where_ false)
@@ -40,45 +39,45 @@ spec = do
4039 it "performs sub SELECTs" $ do
4140 let
4241 selection = ((#col1 + #col2) `As` #sum :& #col1 :& RNil) `from` #table1
43− statement :: Statement '[] Tables Tables SumAndCol1
42+ statement :: Statement '[] SumAndCol1 Tables Tables
4443 statement = select $ starFrom (subselect (selection `As` #sub))
4544 statement `shouldRenderAs`
4645 "SELECT * FROM SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 AS sub;"
4746 it "does LIMIT clauses" $ do
4847 let
49− statement :: Statement '[] Tables Tables Columns
48+ statement :: Statement '[] Columns Tables Tables
5049 statement = select $ starFrom (#table1 & limit 1)
5150 statement `shouldRenderAs` "SELECT * FROM table1 AS table1 LIMIT 1;"
5251 it "should use the minimum of given LIMITs" $ do
5352 let
54− statement :: Statement '[] Tables Tables Columns
53+ statement :: Statement '[] Columns Tables Tables
5554 statement = select $ starFrom (#table1 & limit 1 & limit 2)
5655 statement `shouldRenderAs`
5756 "SELECT * FROM table1 AS table1 LIMIT CASE WHEN (1 <= 2) THEN 1 ELSE 2 END;"
5857 it "should render parameters using $ signs" $ do
5958 let
60− statement :: Statement '[ 'NotNull 'PGInt8] Tables Tables Columns
59+ statement :: Statement '[ 'Required ('NotNull 'PGInt8)] Columns Tables Tables
6160 statement = select $ starFrom (#table1 & limit param1)
6261 statement `shouldRenderAs` "SELECT * FROM table1 AS table1 LIMIT $1;"
6362 it "does OFFSET clauses" $ do
6463 let
65− statement :: Statement '[] Tables Tables Columns
64+ statement :: Statement '[] Columns Tables Tables
6665 statement = select $ starFrom (#table1 & offset 1)
6766 statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET 1;"
6867 it "should use the sum of given OFFSETs" $ do
6968 let
70− statement :: Statement '[] Tables Tables Columns
69+ statement :: Statement '[] Columns Tables Tables
7170 statement = select $ starFrom (#table1 & offset 1 & offset 2)
7271 statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET (1 + 2);"
7372 it "correctly render simple INSERTs" $ do
7473 let
75− statement :: Statement '[] Tables Tables '[]
74+ statement :: Statement '[] '[] Tables Tables
7675 statement = insertInto #table1 $ 2 `As` #col1 :& 4 `As` #col2 :& RNil
7776 statement `shouldRenderAs`
7877 "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
7978 it "should be safe against SQL injection in literal text" $ do
8079 let
81− statement :: Statement '[] StudentsTable StudentsTable '[]
80+ statement :: Statement '[] '[] StudentsTable StudentsTable
8281 statement = insertInto #students $
8382 "Robert'); DROP TABLE students;" `As` #name :& RNil
8483 statement `shouldRenderAs`
@@ -86,12 +85,12 @@ spec = do
8685 describe "JOINs" $ do
8786 let
8887 vals =
89− #orders .&. #orderVal `As` #orderVal
90− :& #customers .&. #customerVal `As` #customerVal
91− :& #shippers .&. #shipperVal `As` #shipperVal :& RNil
88+ #orders &. #orderVal `As` #orderVal
89+ :& #customers &. #customerVal `As` #customerVal
90+ :& #shippers &. #shipperVal `As` #shipperVal :& RNil
9291 it "should render CROSS JOINs" $ do
9392 let
94− statement :: Statement '[] JoinTables JoinTables ValueColumns
93+ statement :: Statement '[] ValueColumns JoinTables JoinTables
9594 statement = select $ vals `from`
9695 (join (#orders & Cross #customers & Cross #shippers))
9796 statement `shouldRenderAs`
@@ -104,14 +103,14 @@ spec = do
104103 \ CROSS JOIN shippers AS shippers;"
105104 it "should render INNER JOINs" $ do
106105 let
107− innerJoins :: FromExpression '[] JoinTables JoinTables
106+ innerJoins :: From '[] JoinTables JoinTables
108107 innerJoins = join $
109108 #orders
110109 & Inner #customers
111− (#orders .&. #customerID ==* #customers .&. #customerID)
110+ (#orders &. #customerID ==* #customers &. #customerID)
112111 & Inner #shippers
113− (#orders .&. #shipperID ==* #shippers .&. #shipperID)
114− selection :: Statement '[] JoinTables JoinTables ValueColumns
112+ (#orders &. #shipperID ==* #shippers &. #shipperID)
113+ selection :: Statement '[] ValueColumns JoinTables JoinTables
115114 selection = select $ vals `from` innerJoins
116115 selection `shouldRenderAs`
117116 "SELECT\
@@ -125,7 +124,7 @@ spec = do
125124 \ ON (orders.shipperID = shippers.shipperID);"
126125 it "should render self JOINs" $ do
127126 let
128− statement :: Statement '[] JoinTables JoinTables OrderColumns
127+ statement :: Statement '[] OrderColumns JoinTables JoinTables
129128 statement = select $ #orders1 `dotStarFrom`
130129 (join (Table (#orders `As` #orders1)
131130 & Cross (#orders `As` #orders2)))
@@ -133,40 +132,55 @@ spec = do
133132 "SELECT orders1.*\
134133 \ FROM orders AS orders1\
135134 \ CROSS JOIN orders AS orders2;"
136− it "should render simple CREATE TABLE statements" $ do
137− let
138− statement :: Statement '[] '[] Tables '[]
139− statement = createTable #table1 (proxy# :: Proxy# Columns)
140− statement `shouldRenderAs`
135+ it "should render CREATE TABLE statements" $ do
136+ createTable #table1
137+ ( (int4 & notNull) `As` #col1
138+ :& (int4 & notNull) `As` #col2
139+ :& RNil)
140+ `shouldRenderAs`
141141 "CREATE TABLE table1 (col1 int4 NOT NULL, col2 int4 NOT NULL);"
142+ createTable #table2
143+ ( serial `As` #col1
144+ :& text `As` #col2
145+ :& (int8 & notNull & default_ 8) `As` #col3
146+ :& RNil)
147+ `shouldRenderAs`
148+ "CREATE TABLE table2 (col1 serial, col2 text, col3 int8 NOT NULL DEFAULT 8);"
142149 it "should render DROP TABLE statements" $ do
143150 let
144− statement :: Statement '[] Tables '[] '[]
151+ statement :: Statement '[] '[] Tables '[]
145152 statement = dropTable #table1
146153 statement `shouldRenderAs` "DROP TABLE table1;"
147154
148−type Columns = '[ "col1" ::: 'NotNull 'PGInt4, "col2" ::: 'NotNull 'PGInt4]
155+type Columns =
156+ '[ "col1" ::: 'Required ('NotNull 'PGInt4)
157+ , "col2" ::: 'Required ('NotNull 'PGInt4)
158+ ]
149159type Tables = '[ "table1" ::: Columns ]
150−type SumAndCol1 = '[ "sum" ::: 'NotNull 'PGInt4, "col1" ::: 'NotNull 'PGInt4]
151−type StudentsColumns = '["name" ::: 'NotNull 'PGText]
160+type SumAndCol1 = '[ "sum" ::: 'Required ('NotNull 'PGInt4), "col1" ::: 'Required ('NotNull 'PGInt4)]
161+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGText)]
152162type StudentsTable = '["students" ::: StudentsColumns]
153163type OrderColumns =
154− [ "orderID" ::: 'NotNull 'PGInt4
155− , "orderVal" ::: 'NotNull 'PGText
156− , "customerID" ::: 'NotNull 'PGInt4
157− , "shipperID" ::: 'NotNull 'PGInt4
158− ]
164+ '[ "orderID" ::: 'Required ('NotNull 'PGInt4)
165+ , "orderVal" ::: 'Required ('NotNull 'PGText)
166+ , "customerID" ::: 'Required ('NotNull 'PGInt4)
167+ , "shipperID" ::: 'Required ('NotNull 'PGInt4)
168+ ]
159169type CustomerColumns =
160− [ "customerID" ::: 'NotNull 'PGInt4, "customerVal" ::: 'NotNull 'PGFloat4 ]
170+ '[ "customerID" ::: 'Required ('NotNull 'PGInt4)
171+ , "customerVal" ::: 'Required ('NotNull 'PGFloat4)
172+ ]
161173type ShipperColumns =
162− [ "shipperID" ::: 'NotNull 'PGInt4, "shipperVal" ::: 'NotNull 'PGBool ]
174+ '[ "shipperID" ::: 'Required ('NotNull 'PGInt4)
175+ , "shipperVal" ::: 'Required ('NotNull 'PGBool)
176+ ]
163177type JoinTables =
164− [ "shippers" ::: ShipperColumns
165− , "customers" ::: CustomerColumns
166− , "orders" ::: OrderColumns
167− ]
178+ '[ "shippers" ::: ShipperColumns
179+ , "customers" ::: CustomerColumns
180+ , "orders" ::: OrderColumns
181+ ]
168182type ValueColumns =
169− [ "orderVal" ::: 'NotNull 'PGText
170− , "customerVal" ::: 'NotNull 'PGFloat4
171− , "shipperVal" ::: 'NotNull 'PGBool
172− ]
183+ '[ "orderVal" ::: 'Required ('NotNull 'PGText)
184+ , "customerVal" ::: 'Required ('NotNull 'PGFloat4)
185+ , "shipperVal" ::: 'Required ('NotNull 'PGBool)
186+ ]
stack.yaml+1−7
@@ -1,9 +1,3 @@
1−resolver: nightly-2016-12-31
1+resolver: nightly-2017-06-26
22packages:
33- squeel-postgresql
4−extra-deps:
5−- bifunctors-5.3
6−- indexed-0.1.3
7−- indexed-extras-0.2
8−flags: {}
9−extra-package-dbs: []