7f34b38 · squeal · git.iko.soy

git.iko.soy/squeal

Merge pull request #41 from echatav/pq-stuff

PQ stuff

commit7f34b38218a1ff300279a85a4772f8b4171fd383 authorEitan Chatav <eitan.chatav@gmail.com> dateWed 16 Aug 2017, 17:43 (9 years ago) parentcfcf7d3 03a7e02

5 files changed+323−97

compare with dev

unifiedsplit

squeal-postgresql/exe/Example.hs+11−7 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+221−41 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+31−11 squeal-postgresql/src/Squeal/PostgreSQL/Statement.hs+53−33 squeal-postgresql/test/Squeal/PostgreSQL/StatementSpec.hs+7−5

squeal-postgresql/exe/Example.hs+11−7

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -fno-warn-unused-imports #-}

12{-# LANGUAGE

23 DataKinds

34 , DeriveGeneric

@@ -44,29 +45,30 @@ main = do

4445 Char8.putStrLn $ "connecting to " <> connectionString

4546 connection0 <- connectdb connectionString

4647 Char8.putStrLn "setting up schema"

47− connection1 <- runPQ (connection0 :: Connection '[]) $ pqExec $

48+ connection1 <- flip execPQ (connection0 :: Connection '[]) $ define $

4849 createTable #students ((text & notNull) `As` #name :* Nil ) []

4950 >>>

5051 createTable #table1

5152 ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil) []

52− connection2 <- runPQ (connection1 :: Connection Schema) $ do

53+ connection2 <- flip execPQ (connection1 :: Connection Schema) $ do

5354 let

54− manipulation :: Manipulation Schema

55+ insert :: Manipulation Schema

5556 '[ 'Required ('NotNull 'PGint4)

5657 , 'Required ('NotNull 'PGint4)

5758 , 'Required ('NotNull 'PGint4)

5859 , 'Required ('NotNull 'PGint4)

5960 ] '[]

60− manipulation =

61+ insert =

6162 insertInto #table1

6263 ( Values

6364 (param (Proxy @1) `As` #col1 :* param (Proxy @2) `As` #col2 :* Nil)

6465 [param (Proxy @3) `As` #col1 :* param (Proxy @4) `As` #col2 :* Nil]

6566 ) Conflict (Returning Nil)

6667 liftBase $ Char8.putStrLn "manipulating"

67− _ <- pqExecParams manipulation (1::Int32,2::Int32,3::Int32,4::Int32)

68+ _insertResult <- manipulateParams insert

69+ (1::Int32,2::Int32,3::Int32,4::Int32)

6870 liftBase $ Char8.putStrLn "querying"

69− Just result <- pqExecNil . query $

71+ result <- query $

7072 selectStar (from (Table (#table1 `As` #table1)))

7173 value00 <- getValue (RowNumber 0) (columnNumber @0) result

7274 value01 <- getValue (RowNumber 0) (columnNumber @1) result

@@ -74,6 +76,7 @@ main = do

7476 value11 <- getValue (RowNumber 1) (columnNumber @1) result

7577 row0 <- getRow (RowNumber 0) result

7678 row1 <- getRow (RowNumber 1) result

79+ rows <- getRows result

7780 liftBase $ do

7881 print (value00 :: Int32)

7982 print (value01 :: Int32)

@@ -81,7 +84,8 @@ main = do

8184 print (value11 :: Int32)

8285 print (row0 :: Table1Row)

8386 print (row1 :: Table1Row)

87+ print (rows :: [Table1Row])

8488 Char8.putStrLn "tearing down schema"

85− connection3 <- runPQ (connection2 :: Connection Schema) $ pqExec $

89+ connection3 <- flip execPQ (connection2 :: Connection Schema) $ define $

8690 dropTable #table1 >>> dropTable #students

8791 finish (connection3 :: Connection '[])

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+221−41

@@ -9,6 +9,7 @@

99 , FlexibleInstances

1010 , MagicHash

1111 , MultiParamTypeClasses

12+ , OverloadedStrings

1213 , RankNTypes

1314 , ScopedTypeVariables

1415 , TypeApplications

@@ -24,7 +25,10 @@ import Control.Monad.Base

2425import Control.Monad.Except

2526import Control.Monad.Trans.Control

2627import Data.ByteString (ByteString)

28+import Data.Foldable

2729import Data.Function ((&))

30+import Data.Monoid

31+import Data.Traversable

2832import Generics.SOP

2933import GHC.Exts hiding (fromList)

3034import GHC.TypeLits

@@ -43,18 +47,18 @@ newtype PQ

4347 (schema1 :: [(Symbol,[(Symbol,ColumnType)])])

4448 (m :: * -> *)

4549 (x :: *) =

46− PQ { unPQ :: Connection schema0 -> m (x, Connection schema1) }

50+ PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }

4751 deriving Functor

4852

49−evalPQ :: Functor m => Connection schema0 -> PQ schema0 schema1 m x -> m x

50−evalPQ conn (PQ pq) = fmap fst $ pq conn

53+evalPQ :: Functor m => PQ schema0 schema1 m x -> Connection schema0 -> m x

54+evalPQ (PQ pq) = fmap fst . pq

5155

52−runPQ

56+execPQ

5357 :: Functor m

54− => Connection schema0

55− -> PQ schema0 schema1 m x

58+ => PQ schema0 schema1 m x

59+ -> Connection schema0

5660 -> m (Connection schema1)

57−runPQ conn (PQ pq) = fmap snd $ pq conn

61+execPQ (PQ pq) = fmap snd . pq

5862

5963pqAp

6064 :: Monad m

@@ -73,7 +77,7 @@ pqBind

7377 -> PQ schema0 schema2 m y

7478pqBind f (PQ x) = PQ $ \ conn -> do

7579 (x', conn') <- x conn

76− unPQ (f x') conn'

80+ runPQ (f x') conn'

7781

7882pqThen

7983 :: Monad m

@@ -82,44 +86,156 @@ pqThen

8286 -> PQ schema0 schema2 m y

8387pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

8488

85−pqExec

89+define

8690 :: MonadBase IO io

8791 => Definition schema0 schema1

88− -> PQ schema0 schema1 io (Maybe (Result '[]))

89−pqExec (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do

90− result <- liftBase $ LibPQ.exec conn q

91− return (Result <$> result, Connection conn)

92−

93−pqThenExec

92+ -> PQ schema0 schema1 io (Result '[])

93+define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do

94+ resultMaybe <- liftBase $ LibPQ.exec conn q

95+ case resultMaybe of

96+ Nothing -> error

97+ "define: LibPQ.exec returned no results"

98+ Just result -> return (Result result, Connection conn)

99+

100+pqThenDefine

94101 :: MonadBase IO io

95102 => Definition schema1 schema2

96103 -> PQ schema0 schema1 io x

97− -> PQ schema0 schema2 io (Maybe (Result '[]))

98−pqThenExec = pqThen . pqExec

104+ -> PQ schema0 schema2 io (Result '[])

105+pqThenDefine = pqThen . define

99106

100−class Monad m => MonadPQ schema m | m -> schema where

107+class Monad pq => MonadPQ schema pq | pq -> schema where

101108

102− pqExecParams

109+ manipulateParams

103110 :: ToParams x params

104− => Manipulation schema params ys -> x -> m (Maybe (Result ys))

105− default pqExecParams

106− :: (MonadTrans t, MonadPQ schema m1, m ~ t m1)

111+ => Manipulation schema params ys -> x -> pq (Result ys)

112+ default manipulateParams

113+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

107114 => ToParams x params

108− => Manipulation schema params ys -> x -> m (Maybe (Result ys))

109− pqExecParams manipulation params = lift $ pqExecParams manipulation params

115+ => Manipulation schema params ys -> x -> pq (Result ys)

116+ manipulateParams manipulation params = lift $

117+ manipulateParams manipulation params

110118

111− pqExecNil :: Manipulation schema '[] ys -> m (Maybe (Result ys))

112− pqExecNil statement = pqExecParams statement ()

119+ manipulate :: Manipulation schema '[] ys -> pq (Result ys)

120+ manipulate statement = manipulateParams statement ()

121+

122+ queryParams

123+ :: ToParams x params

124+ => Query schema params ys -> x -> pq (Result ys)

125+ queryParams = manipulateParams . queryStatement

126+

127+ query :: Query schema '[] ys -> pq (Result ys)

128+ query q = queryParams q ()

129+

130+ traversePrepared

131+ :: (ToParams x params, Traversable list)

132+ => Manipulation schema params ys -> list x -> pq (list (Result ys))

133+ default traversePrepared

134+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

135+ => (ToParams x params, Traversable list)

136+ => Manipulation schema params ys -> list x -> pq (list (Result ys))

137+ traversePrepared manipulation params = lift $

138+ traversePrepared manipulation params

139+

140+ forPrepared

141+ :: (ToParams x params, Traversable list)

142+ => list x -> Manipulation schema params ys -> pq (list (Result ys))

143+ forPrepared = flip traversePrepared

144+

145+ traversePrepared_

146+ :: (ToParams x params, Foldable list)

147+ => Manipulation schema params ys -> list x -> pq ()

148+ default traversePrepared_

149+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

150+ => (ToParams x params, Foldable list)

151+ => Manipulation schema params ys -> list x -> pq ()

152+ traversePrepared_ manipulation params = lift $

153+ traversePrepared_ manipulation params

154+

155+ forPrepared_

156+ :: (ToParams x params, Traversable list)

157+ => list x -> Manipulation schema params ys -> pq ()

158+ forPrepared_ = flip traversePrepared_

159+

160+ liftPQ :: (LibPQ.Connection -> IO a) -> pq a

161+ default liftPQ

162+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

163+ => (LibPQ.Connection -> IO a) -> pq a

164+ liftPQ = lift . liftPQ

113165

114166instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

115167

116− pqExecParams (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

117− PQ $ \ (Connection conn) -> do

118− let

119− toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

120− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

121− result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

122− return (Result <$> result, Connection conn)

168+ manipulateParams

169+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

170+ PQ $ \ (Connection conn) -> do

171+ let

172+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

173+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

174+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

175+ case resultMaybe of

176+ Nothing -> error

177+ "manipulateParams: LibPQ.execParams returned no results"

178+ Just result -> return (Result result, Connection conn)

179+

180+ traversePrepared

181+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

182+ PQ $ \ (Connection conn) -> do

183+ let temp = "temporary_statement"

184+ prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

185+ case prepResultMaybe of

186+ Nothing -> error

187+ "traversePrepared: LibPQ.prepare returned no results"

188+ Just _prepResult -> return () -- todo: check status of prepResult

189+ results <- for list $ \ params -> do

190+ let

191+ toParam' bytes = (bytes,LibPQ.Binary)

192+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

193+ resultMaybe <- liftBase $

194+ LibPQ.execPrepared conn temp params' LibPQ.Binary

195+ case resultMaybe of

196+ Nothing -> error

197+ "traversePrepared: LibPQ.execParams returned no results"

198+ Just result -> return $ Result result

199+ deallocResultMaybe <- liftBase $

200+ LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

201+ case deallocResultMaybe of

202+ Nothing -> error

203+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

204+ Just _deallocResult -> return ()

205+ -- todo: check status of deallocResult

206+ return (results, Connection conn)

207+

208+ traversePrepared_

209+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

210+ PQ $ \ (Connection conn) -> do

211+ let temp = "temporary_statement"

212+ prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

213+ case prepResultMaybe of

214+ Nothing -> error

215+ "traversePrepared_: LibPQ.prepare returned no results"

216+ Just _prepResult -> return () -- todo: check status of prepResult

217+ for_ list $ \ params -> do

218+ let

219+ toParam' bytes = (bytes,LibPQ.Binary)

220+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

221+ resultMaybe <- liftBase $

222+ LibPQ.execPrepared conn temp params' LibPQ.Binary

223+ case resultMaybe of

224+ Nothing -> error

225+ "traversePrepared_: LibPQ.execParams returned no results"

226+ Just _result -> return ()

227+ deallocResultMaybe <- liftBase $

228+ LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

229+ case deallocResultMaybe of

230+ Nothing -> error

231+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

232+ Just _deallocResult -> return ()

233+ -- todo: check status of deallocResult

234+ return ((), Connection conn)

235+

236+ liftPQ pq = PQ $ \ (Connection conn) -> do

237+ y <- liftBase $ pq conn

238+ return (y, Connection conn)

123239

124240instance Monad m => Applicative (PQ schema schema m) where

125241 pure x = PQ $ \ conn -> pure (x, conn)

@@ -142,7 +258,7 @@ type PQRun schema =

142258

143259pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

144260pqliftWith f = PQ $ \ conn ->

145− fmap (\ x -> (x, conn)) (f $ \ pq -> unPQ pq conn)

261+ fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)

146262

147263instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where

148264 type StM (PQ schema schema m) x = StM m (x, Connection schema)

@@ -157,12 +273,12 @@ finish :: MonadBase IO io => Connection schema -> io ()

157273finish = liftBase . LibPQ.finish . unConnection

158274

159275withConnection

160− :: MonadBaseControl IO io

276+ :: forall schema io x

277+ . MonadBaseControl IO io

161278 => ByteString

162279 -> (Connection schema -> io x)

163280 -> io x

164−withConnection connString action =

165− bracket (connectdb connString) finish action

281+withConnection connString = bracket (connectdb connString) finish

166282

167283newtype Result (xs :: [(Symbol,ColumnType)])

168284 = Result { unResult :: LibPQ.Result }

@@ -192,15 +308,79 @@ getValue

192308 (RowNumber r)

193309 (UnsafeColumnNumber c :: ColumnNumber n columns colty)

194310 (Result result)

195− = fromColumnValue @colty . K <$>

196− liftBase (LibPQ.getvalue result r c)

311+ = fmap (fromColumnValue @colty . K) $ liftBase $ do

312+ numRows <- LibPQ.ntuples result

313+ when (numRows < r) $ error $

314+ "getValue: expected at least " <> show r <> "rows but only saw "

315+ <> show numRows

316+ LibPQ.getvalue result r c

197317

198318getRow

199319 :: (FromRow columns y, MonadBase IO io)

200320 => RowNumber -> Result columns -> io y

201−getRow (RowNumber r) (Result result :: Result columns) = do

321+getRow (RowNumber r) (Result result :: Result columns) = liftBase $do

322+ numRows <- LibPQ.ntuples result

323+ when (numRows < r) $ error $

324+ "getRow: expected at least " <> show r <> "rows but only saw "

325+ <> show numRows

202326 let len = fromIntegral (lengthSList (Proxy @columns))

203− row' <- traverse (liftBase . LibPQ.getvalue result r) [0 .. len - 1]

327+ numCols <- LibPQ.nfields result

328+ when (numCols /= len) $ error $

329+ "getRow: expected at least " <> show len <> "columns but only saw "

330+ <> show numCols

331+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

204332 case fromList row' of

205333 Nothing -> error "getRow: found unexpected length"

206334 Just row -> return $ fromRow @columns row

335+

336+nextRow

337+ :: (FromRow columns y, MonadBase IO io)

338+ => Result columns -> RowNumber -> io (Maybe (RowNumber,y))

339+nextRow (Result result :: Result columns) (RowNumber r) = liftBase $ do

340+ numRows <- LibPQ.ntuples result -- todo: cache this

341+ if numRows < r then return Nothing else do

342+ let len = fromIntegral (lengthSList (Proxy @columns))

343+ numCols <- LibPQ.nfields result -- todo: cache this

344+ when (numCols /= len) $ error $

345+ "nextRow: expected at least " <> show len <> "columns but only saw "

346+ <> show numCols

347+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

348+ case fromList row' of

349+ Nothing -> error "nextRow: found unexpected length"

350+ Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)

351+

352+getRows :: (FromRow columns y, MonadBase IO io) => Result columns -> io [y]

353+getRows (Result result :: Result columns) = liftBase $ do

354+ let len = fromIntegral (lengthSList (Proxy @columns))

355+ numCols <- LibPQ.nfields result

356+ when (numCols /= len) $ error $

357+ "getRow: expected at least " <> show len <> "columns but only saw "

358+ <> show numCols

359+ numRows <- LibPQ.ntuples result

360+ for [0 .. numRows - 1] $ \ r -> do

361+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

362+ case fromList row' of

363+ Nothing -> error "getRows: found unexpected length"

364+ Just row -> return $ fromRow @columns row

365+

366+getRowMaybe

367+ :: (FromRow columns y, MonadBase IO io)

368+ => RowNumber -> Result columns -> io (Maybe y)

369+getRowMaybe (RowNumber r) (Result result :: Result columns) = liftBase $do

370+ numRows <- LibPQ.ntuples result

371+ if numRows < r then return Nothing else do

372+ let len = fromIntegral (lengthSList (Proxy @columns))

373+ numCols <- LibPQ.nfields result

374+ when (numCols /= len) $ error $

375+ "getRow: expected at least " <> show len <> "columns but only saw "

376+ <> show numCols

377+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

378+ case fromList row' of

379+ Nothing -> error "getRow: found unexpected length"

380+ Just row -> return . Just $ fromRow @columns row

381+

382+liftResult

383+ :: MonadBase IO io

384+ => (LibPQ.Result -> IO x)

385+ -> Result results -> io x

386+liftResult f (Result result) = liftBase $ f result

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+31−11

@@ -24,19 +24,22 @@ module Squeal.PostgreSQL.Schema

2424 , renderAlias

2525 , Aliased (As)

2626 , renderAliased

27+ , IsTableColumn (..)

2728 , NullityType (..)

29+ , ColumnType (..)

30+ , Grouping (..)

31+ , SameTypes

32+ , AllNotNull

33+ , NotAllNull

2834 , NullifyType

2935 , NullifyColumns

3036 , NullifyTables

31− , ColumnType (..)

3237 , BaseType

3338 , Create

3439 , Drop

3540 , Alter

3641 , Rename

3742 , Join

38− , Grouping (..)

39− , IsTableColumn (..)

4043 , module GHC.OverloadedLabels

4144 , module GHC.TypeLits

4245 ) where

@@ -44,6 +47,7 @@ module Squeal.PostgreSQL.Schema

4447import Data.ByteString

4548import Data.Monoid

4649import Data.String

50+import GHC.Exts

4751import GHC.OverloadedLabels

4852import GHC.TypeLits

4953

@@ -113,13 +117,37 @@ renderAliased

113117renderAliased render (expression `As` alias) =

114118 render expression <> " AS " <> renderAlias alias

115119

120+class IsTableColumn table column expression where

121+ (!) :: Alias table -> Alias column -> expression

122+ infixl 9 !

123+instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)

124+

116125data NullityType = Null PGType | NotNull PGType

117126

118127data ColumnType = Optional NullityType | Required NullityType

119128

129+data Grouping

130+ = Ungrouped

131+ | Grouped [(Symbol,Symbol)]

132+

120133type family BaseType (ty :: ColumnType) where

121134 BaseType (optionality (nullity pg)) = pg

122135

136+type family SameTypes columns0 columns1 :: Constraint where

137+ SameTypes '[] '[] = ()

138+ SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)

139+ = (ty0 ~ ty1, SameTypes columns0 columns1)

140+

141+type family AllNotNull columns :: Constraint where

142+ AllNotNull '[] = ()

143+ AllNotNull ((column ::: (optionality ('NotNull ty))) ': columns)

144+ = AllNotNull columns

145+

146+type family NotAllNull columns :: Constraint where

147+ NotAllNull ((column ::: (optionality ('NotNull ty))) ': columns) = ()

148+ NotAllNull ((column ::: (optionality ('Null ty))) ': columns)

149+ = NotAllNull columns

150+

123151type family NullifyType (ty :: ColumnType) where

124152 NullifyType (optionality ('Null ty)) = optionality ('Null ty)

125153 NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)

@@ -153,11 +181,3 @@ type family Rename alias0 alias1 xs where

153181type family Join xs ys where

154182 Join '[] ys = ys

155183 Join (x ': xs) ys = x ': Join xs ys

156−

157−data Grouping

158− = Ungrouped

159− | Grouped [(Symbol,Symbol)]

160−

161−class IsTableColumn table column expression where

162− (!) :: Alias table -> Alias column -> expression

163− infixl 9 !

squeal-postgresql/src/Squeal/PostgreSQL/Statement.hs+53−33

@@ -80,12 +80,12 @@ instance (HasTable table tables columns, HasColumn column columns ty)

8080 table ! column = UnsafeExpression $

8181 renderAlias table <> "." <> renderAlias column

8282

83−def :: Expression params '[] grouping ('Optional (nullity ty))

83+def :: Expression params '[] 'Ungrouped ('Optional (nullity ty))

8484def = UnsafeExpression "DEFAULT"

8585

8686unDef

87− :: Expression params '[] grouping ('Required (nullity ty))

88− -> Expression params '[] grouping ('Optional (nullity ty))

87+ :: Expression params '[] 'Ungrouped ('Required (nullity ty))

88+ -> Expression params '[] 'Ungrouped ('Optional (nullity ty))

8989unDef = UnsafeExpression . renderExpression

9090

9191null :: Expression params tables grouping (optionality ('Null ty))

@@ -909,10 +909,10 @@ newtype Query

909909 (columns :: [(Symbol,ColumnType)])

910910 = UnsafeQuery { renderQuery :: ByteString }

911911

912−query

912+queryStatement

913913 :: Query schema params columns

914914 -> Manipulation schema params columns

915−query q = UnsafeManipulation $ renderQuery q <> ";"

915+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"

916916

917917union, unionAll, intersect, intersectAll, except, exceptAll

918918 :: Query schema params columns

@@ -958,7 +958,7 @@ select list tabs = UnsafeQuery $

958958 <+> renderTableExpression tabs

959959

960960selectStar

961− :: (tables ~ '[table ::: columns])

961+ :: tables ~ '[table ::: columns]

962962 => TableExpression params schema tables 'Ungrouped

963963 -> Query schema params columns

964964selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs

@@ -1009,7 +1009,7 @@ data TableConstraint

10091009 = UnsafeTableConstraint { renderTableConstraint :: ByteString }

10101010

10111011check

1012− :: (forall table. Condition '[] '[table ::: columns] 'Ungrouped)

1012+ :: Condition '[] '[table ::: columns] 'Ungrouped

10131013 -> TableConstraint schema columns

10141014check condition = UnsafeTableConstraint $

10151015 "CHECK" <+> parenthesized (renderExpression condition)

@@ -1034,36 +1034,53 @@ unique columns = UnsafeTableConstraint $

10341034 "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)

10351035

10361036primaryKey

1037− :: (SListI subcolumns, NotNullTypes subcolumns)

1037+ :: (SListI subcolumns, AllNotNull subcolumns)

10381038 => NP (Column columns) subcolumns

10391039 -> TableConstraint schema columns

10401040primaryKey columns = UnsafeTableConstraint $

10411041 "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

10421042

1043−type family SameTypes columns0 columns1 :: Constraint where

1044− SameTypes '[] '[] = ()

1045− SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)

1046− = (ty0 ~ ty1, SameTypes columns0 columns1)

1047−

1048−type family NotNullTypes columns :: Constraint where

1049− NotNullTypes '[] = ()

1050− NotNullTypes ((column ::: (optionality ('NotNull ty))) ': columns)

1051− = NotNullTypes columns

1052−

10531043foreignKey

10541044 :: ( HasTable reftable schema refcolumns

10551045 , SameTypes subcolumns refsubcolumns

1056− , NotNullTypes subcolumns

1046+ , NotAllNull subcolumns

10571047 , SListI subcolumns

10581048 , SListI refsubcolumns)

10591049 => NP (Column columns) subcolumns

10601050 -> Alias reftable

10611051 -> NP (Column refcolumns) refsubcolumns

1052+ -> OnDelete

1053+ -> OnUpdate

10621054 -> TableConstraint schema columns

1063−foreignKey columns reftable refcolumns = UnsafeTableConstraint $

1064− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

1065− <+> "REFERENCES" <+> renderAlias reftable

1066− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)

1055+foreignKey columns reftable refcolumns onDelete onUpdate =

1056+ UnsafeTableConstraint $

1057+ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

1058+ <+> "REFERENCES" <+> renderAlias reftable

1059+ <+> parenthesized (renderCommaSeparated renderColumn refcolumns)

1060+ <+> renderOnDelete onDelete

1061+ <+> renderOnUpdate onUpdate

1062+

1063+data OnDelete

1064+ = OnDeleteNoAction

1065+ | OnDeleteRestrict

1066+ | OnDeleteCascade

1067+

1068+renderOnDelete :: OnDelete -> ByteString

1069+renderOnDelete = \case

1070+ OnDeleteNoAction -> "ON DELETE NO ACTION"

1071+ OnDeleteRestrict -> "ON DELETE RESTRICT"

1072+ OnDeleteCascade -> "ON DELETE CASCADE"

1073+

1074+data OnUpdate

1075+ = OnUpdateNoAction

1076+ | OnUpdateRestrict

1077+ | OnUpdateCascade

1078+

1079+renderOnUpdate :: OnUpdate -> ByteString

1080+renderOnUpdate = \case

1081+ OnUpdateNoAction -> "ON UPDATE NO ACTION"

1082+ OnUpdateRestrict -> "ON UPDATE RESTRICT"

1083+ OnUpdateCascade -> "ON UPDATE CASCADE"

10671084

10681085{-----------------------------------------

10691086DROP statements

@@ -1218,7 +1235,8 @@ data ReturningClause

12181235 where

12191236 ReturningStar :: ReturningClause params columns columns

12201237 Returning

1221− :: NP (Aliased (Expression params '[table ::: columns] 'Ungrouped))

1238+ :: NP

1239+ (Aliased (Expression params '[table ::: columns] 'Ungrouped))

12221240 results

12231241 -> ReturningClause params columns results

12241242

@@ -1236,8 +1254,8 @@ data ConflictClause params columns where

12361254 Conflict :: ConflictClause params columns

12371255 OnConflictDoNothing :: ConflictClause params columns

12381256 OnConflictDoUpdate

1239− :: NP (Aliased (UpdateExpression params '[table ::: columns])) columns

1240− -> Condition params '[table ::: columns] 'Ungrouped

1257+ :: NP (Aliased (UpdateExpression params columns)) columns

1258+ -> Maybe (Condition params '[table ::: columns] 'Ungrouped)

12411259 -> ConflictClause params columns

12421260

12431261renderConflictClause

@@ -1247,21 +1265,23 @@ renderConflictClause

12471265renderConflictClause = \case

12481266 Conflict -> ""

12491267 OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

1250− OnConflictDoUpdate updates wh

1268+ OnConflictDoUpdate updates whMaybe

12511269 -> " ON CONFLICT DO UPDATE SET"

12521270 <+> renderCommaSeparatedMaybe renderUpdateExpression updates

1253− <+> "WHERE" <+> renderExpression wh

1271+ <> case whMaybe of

1272+ Nothing -> ""

1273+ Just wh -> " WHERE" <+> renderExpression wh

12541274

12551275{-----------------------------------------

12561276UPDATE statements

12571277-----------------------------------------}

12581278

1259−data UpdateExpression params table ty

1279+data UpdateExpression params columns ty

12601280 = Same

1261− | Set (Expression params table 'Ungrouped ty)

1281+ | Set (forall table. Expression params '[table ::: columns] 'Ungrouped ty)

12621282

12631283renderUpdateExpression

1264− :: Aliased (UpdateExpression params '[table ::: columns]) column

1284+ :: Aliased (UpdateExpression params columns) column

12651285 -> Maybe ByteString

12661286renderUpdateExpression = \case

12671287 Same `As` _ -> Nothing

@@ -1271,8 +1291,8 @@ renderUpdateExpression = \case

12711291update

12721292 :: (HasTable table schema columns, SListI columns, SListI results)

12731293 => Alias table

1274− -> NP (Aliased (UpdateExpression params '[table ::: columns])) columns

1275− -> Condition params '[table ::: columns] 'Ungrouped

1294+ -> NP (Aliased (UpdateExpression params columns)) columns

1295+ -> Condition params '[tab ::: columns] 'Ungrouped

12761296 -> ReturningClause params columns results

12771297 -> Manipulation schema params results

12781298update table columns wh returning = UnsafeManipulation $

squeal-postgresql/test/Squeal/PostgreSQL/StatementSpec.hs+7−5

@@ -20,7 +20,7 @@ import Squeal.PostgreSQL.Schema

2020spec :: Spec

2121spec = do

2222 let

23− qry `queryRenders` str = query qry `manipulationRenders` str

23+ qry `queryRenders` str = queryStatement qry `manipulationRenders` str

2424 definition `definitionRenders` str =

2525 renderDefinition definition `shouldBe` str

2626 manipulation `manipulationRenders` str =

@@ -141,12 +141,12 @@ spec = do

141141 statement =

142142 insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])

143143 (OnConflictDoUpdate

144− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) (#col1 /=* #col2))

144+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)

145145 (Returning Nil)

146146 statement `manipulationRenders`

147147 "INSERT INTO table1 (col1, col2) VALUES (2, 4)\

148148 \ ON CONFLICT DO UPDATE\

149− \ SET col1 = 2 WHERE (col1 <> col2);"

149+ \ SET col1 = 2;"

150150 it "correctly renders returning upsert INSERTs" $ do

151151 let

152152 statement :: Manipulation Tables '[] SumAndCol1

@@ -154,7 +154,7 @@ spec = do

154154 insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])

155155 (OnConflictDoUpdate

156156 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

157− (#col1 /=* #col2))

157+ (Just (#col1 /=* #col2)))

158158 (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)

159159 statement `manipulationRenders`

160160 "INSERT INTO table1 (col1, col2) VALUES (2, 4)\

@@ -269,6 +269,7 @@ spec = do

269269 (text & notNull) `As` #email :* Nil )

270270 [ primaryKey (Column #id :* Nil)

271271 , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)

272+ OnDeleteCascade OnUpdateRestrict

272273 , unique (Column #email :* Nil)

273274 , check (#email /=* "")

274275 ]

@@ -282,7 +283,8 @@ spec = do

282283 \ userid integer NOT NULL,\

283284 \ email text NOT NULL,\

284285 \ PRIMARY KEY (id),\

285− \ FOREIGN KEY (userid) REFERENCES users (id),\

286+ \ FOREIGN KEY (userid) REFERENCES users (id)\

287+ \ ON DELETE CASCADE ON UPDATE RESTRICT,\

286288 \ UNIQUE (email),\

287289 \ CHECK ((email <> E'')));"

288290 it "should render DROP TABLE statements" $ do