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

Returning

commit687bbdec485107e52e6704430f17cfa3fc0844cd authorEitan Chatav <eitan.chatav@gmail.com> dateWed 26 Jul 2017, 10:25 (9 years ago) parentd6e6130a1b731e
5 files changed+441−235
compare with dev
unifiedsplit
squeel-postgresql/squeel-postgresql.cabal−3 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+13−13 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+370−202 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+58−11 squeel-postgresql/test/Squeel/PostgreSQL/ValueSpec.hs−6
squeel-postgresql/squeel-postgresql.cabal−3
@@ -23,7 +23,6 @@ library
2323 build-depends:
2424 aeson
2525 , base
26− , Boolean
2726 , bytestring
2827 , generics-sop
2928 , lifted-base
@@ -46,10 +45,8 @@ test-suite squeel-postgresql-test
4645 main-is: Spec.hs
4746 other-modules:
4847 Squeel.PostgreSQL.StatementSpec
49− Squeel.PostgreSQL.ValueSpec
5048 build-depends:
5149 base
52− , Boolean
5350 , generics-sop
5451 , hspec
5552 , squeel-postgresql
squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+13−13
@@ -114,11 +114,11 @@ class MonadPQ db m | m -> db where
114114 -> m (Maybe (Result ys))
115115 pqExecNil statement = pqExecParams statement Nil
116116
117− pqExecPrepared
118− :: AllZip HasEncoding ps xs
119− => PreparedStatement ps ys db db
120− -> NP I xs
121− -> m (Maybe (Result ys))
117+ -- pqExecPrepared
118+ -- :: AllZip HasEncoding ps xs
119+ -- => PreparedStatement ps ys db db
120+ -- -> NP I xs
121+ -- -> m (Maybe (Result ys))
122122
123123instance AtkeyPQ PQ where
124124
@@ -158,14 +158,14 @@ instance MonadBase IO io => MonadPQ db (PQ db db io) where
158158 result <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
159159 return (Result <$> result, Connection conn)
160160
161− pqExecPrepared (q :: PreparedStatement ps ys db0 db1) params =
162− PQ $ \ (Connection conn) -> do
163− let
164− paramValues = encodings (Proxy :: Proxy ps) params
165− params' = [ Just (param', LibPQ.Binary) | param' <- paramValues ]
166− result <- liftBase $
167− LibPQ.execPrepared conn (renderPreparedStatement q) params' LibPQ.Binary
168− return (Result <$> result, Connection conn)
161+ -- pqExecPrepared (q :: PreparedStatement ps ys db0 db1) params =
162+ -- PQ $ \ (Connection conn) -> do
163+ -- let
164+ -- paramValues = encodings (Proxy :: Proxy ps) params
165+ -- params' = [ Just (param', LibPQ.Binary) | param' <- paramValues ]
166+ -- result <- liftBase $
167+ -- LibPQ.execPrepared conn (renderPreparedStatement q) params' LibPQ.Binary
168+ -- return (Result <$> result, Connection conn)
169169
170170instance Monad m => Applicative (PQ db db m) where
171171 pure x = PQ $ \ conn -> pure (x, conn)
squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+370−202
@@ -1,6 +1,7 @@
11{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
22{-# LANGUAGE
33 DataKinds
4+ , FlexibleContexts
45 , FlexibleInstances
56 , FunctionalDependencies
67 , GADTs
@@ -16,9 +17,8 @@
1617
1718module Squeel.PostgreSQL.Statement where
1819
19−import Data.Boolean
20−import Data.Boolean.Numbers
2120import Data.ByteString (ByteString)
21+import Data.Foldable
2222import Data.Maybe
2323import Data.Monoid
2424import Data.Ratio
@@ -179,6 +179,14 @@ instance (PGFloating ty, PGCast 'PGNumeric ty, PGTyped ty)
179179 acosh x = log (x + sqrt (x*x - 1))
180180 atanh x = log ((1 + x) / (1 - x)) / 2
181181
182+atan2
183+ :: PGFloating float
184+ => Expression params tables ('Required (nullity float))
185+ -> Expression params tables ('Required (nullity float))
186+ -> Expression params tables ('Required (nullity float))
187+atan2 y x = UnsafeExpression $
188+ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
189+
182190class PGCast (ty0 :: PGType) (ty1 :: PGType) where
183191 cast
184192 :: TypeExpression ('Required ('Null ty1))
@@ -199,52 +207,52 @@ instance PGCast 'PGInt8 'PGFloat4
199207instance PGCast 'PGInt8 'PGFloat8
200208instance PGCast 'PGInt8 'PGNumeric
201209
202−instance (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty)
203− => NumB (Expression params tables ('Required (nullity ty))) where
204− type IntegerOf (Expression params tables ('Required (nullity ty)))
205− = (Expression params tables ('Required (nullity 'PGInt8)))
206− fromIntegerB = cast pgtype
207−
208−instance (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
209− => IntegralB (Expression params tables ('Required ('NotNull ty))) where
210− quot = unsafeBinaryOp "/"
211− rem = unsafeBinaryOp "%"
212− div = unsafeBinaryOp "/"
213− mod = unsafeBinaryOp "%"
214− toIntegerB = cast int8
215−
216−instance
217− ( IntegerOf (Expression params tables ('Required ('NotNull ty)))
218− ~ (Expression params tables ('Required ('NotNull 'PGInt8)))
219− , PGNum ty
220− , PGTyped ty
221− , PGCast 'PGInt8 ty
222− , PGFractional ty
223− )
224− => RealFracB (Expression params tables ('Required ('NotNull ty))) where
225− properFraction x = (truncate x, x - unsafeFunction "trunc" x)
226− truncate = fromIntegerB . unsafeFunction "trunc"
227− round = fromIntegerB . unsafeFunction "round"
228− ceiling = fromIntegerB . unsafeFunction "ceiling"
229− floor = fromIntegerB . unsafeFunction "floor"
230−
231−instance
232− ( IntegerOf (Expression params tables ('Required ('NotNull ty)))
233− ~ (Expression params tables ('Required ('NotNull 'PGInt8)))
234− , PGNum ty
235− , PGTyped ty
236− , PGCast 'PGInt8 ty
237− , PGCast 'PGNumeric ty
238− , PGFloating ty
239− )
240− => RealFloatB (Expression params tables ('Required ('NotNull ty))) where
241− isNaN x = x ==* UnsafeExpression "\'NaN\'"
242− isInfinite x = x ==* UnsafeExpression "\'Infinity\'"
243− ||* x ==* UnsafeExpression "\'-Infinity\'"
244− isNegativeZero x = x ==* UnsafeExpression "-0"
245− isIEEE _ = true
246− atan2 y x = UnsafeExpression $
247− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
210+div
211+ :: (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
212+ => Expression params tables ('Required (nullity ty))
213+ -> Expression params tables ('Required (nullity ty))
214+ -> Expression params tables ('Required (nullity ty))
215+div = unsafeBinaryOp "/"
216+
217+mod
218+ :: (PGNum ty, PGTyped ty, PGCast 'PGInt8 ty, PGCast ty 'PGInt8)
219+ => Expression params tables ('Required (nullity ty))
220+ -> Expression params tables ('Required (nullity ty))
221+ -> Expression params tables ('Required (nullity ty))
222+mod = unsafeBinaryOp "%"
223+
224+truncate
225+ :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
226+ => Expression params tables ('Required (nullity frac))
227+ -> Expression params tables ('Required (nullity int))
228+truncate = cast pgtype . truncate'
229+ where
230+ truncate'
231+ :: Expression params tables ('Required (nullity frac))
232+ -> Expression params tables ('Required (nullity 'PGInt4))
233+ truncate' = unsafeFunction "trunc"
234+
235+round
236+ :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
237+ => Expression params tables ('Required (nullity frac))
238+ -> Expression params tables ('Required (nullity int))
239+round = cast pgtype . round'
240+ where
241+ round'
242+ :: Expression params tables ('Required (nullity frac))
243+ -> Expression params tables ('Required (nullity 'PGInt4))
244+ round' = unsafeFunction "round"
245+
246+ceiling
247+ :: (PGFractional frac, PGCast 'PGInt4 int, PGTyped int)
248+ => Expression params tables ('Required (nullity frac))
249+ -> Expression params tables ('Required (nullity int))
250+ceiling = cast pgtype . ceiling'
251+ where
252+ ceiling'
253+ :: Expression params tables ('Required (nullity frac))
254+ -> Expression params tables ('Required (nullity 'PGInt4))
255+ ceiling' = unsafeFunction "ceiling"
248256
249257instance IsString (Expression params tables ('Required (nullity 'PGText))) where
250258 fromString str = UnsafeExpression $
@@ -261,18 +269,33 @@ instance IsString (Expression params tables ('Required (nullity 'PGText))) where
261269 '\\' -> "\\\\"
262270 c -> [c]
263271
264−instance Boolean (Expression params tables ('Required ('NotNull 'PGBool))) where
265− true = UnsafeExpression "TRUE"
266− false = UnsafeExpression "FALSE"
267− notB = unsafeUnaryOp "NOT"
268− (&&*) = unsafeBinaryOp "AND"
269− (||*) = unsafeBinaryOp "OR"
272+type Predicate params tables = Expression params tables ('Required ('NotNull 'PGBool))
273+
274+true :: Predicate params tables
275+true = UnsafeExpression "TRUE"
270276
271−type instance BooleanOf (Expression params tables ty) =
272− Expression params tables ('Required ('NotNull 'PGBool))
277+false :: Predicate params tables
278+false = UnsafeExpression "FALSE"
279+
280+notB
281+ :: Predicate params tables
282+ -> Predicate params tables
283+notB = unsafeUnaryOp "NOT"
284+
285+(&&*)
286+ :: Predicate params tables
287+ -> Predicate params tables
288+ -> Predicate params tables
289+(&&*) = unsafeBinaryOp "AND"
290+
291+(||*)
292+ :: Predicate params tables
293+ -> Predicate params tables
294+ -> Predicate params tables
295+(||*) = unsafeBinaryOp "OR"
273296
274297caseWhenThenElse
275− :: [(Expression params tables ('Required ('NotNull 'PGBool)), Expression params tables ty)]
298+ :: [(Predicate params tables, Expression params tables ty)]
276299 -> Expression params tables ty
277300 -> Expression params tables ty
278301caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
@@ -288,34 +311,64 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
288311 , " END"
289312 ]
290313
291−instance IfB (Expression params tables ty) where
292− ifB if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
314+ifThenElse
315+ :: Predicate params tables
316+ -> Expression params tables ty
317+ -> Expression params tables ty
318+ -> Expression params tables ty
319+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
320+
321+(==*)
322+ :: Expression params tables ty
323+ -> Expression params tables ty
324+ -> Predicate params tables
325+(==*) = unsafeBinaryOp "="
326+
327+(/=*)
328+ :: Expression params tables ty
329+ -> Expression params tables ty
330+ -> Predicate params tables
331+(/=*) = unsafeBinaryOp "<>"
332+
333+(>=*)
334+ :: Expression params tables ty
335+ -> Expression params tables ty
336+ -> Predicate params tables
337+(>=*) = unsafeBinaryOp ">="
338+
339+(<*)
340+ :: Expression params tables ty
341+ -> Expression params tables ty
342+ -> Predicate params tables
343+(<*) = unsafeBinaryOp "<"
293344
294−instance EqB (Expression params tables (optionality ('NotNull ty))) where
295− (==*) = unsafeBinaryOp "="
296− (/=*) = unsafeBinaryOp "<>"
345+(<=*)
346+ :: Expression params tables ty
347+ -> Expression params tables ty
348+ -> Predicate params tables
349+(<=*) = unsafeBinaryOp "<="
297350
298−instance OrdB (Expression params tables (optionality ('NotNull ty))) where
299− (>*) = unsafeBinaryOp ">"
300− (>=*) = unsafeBinaryOp ">="
301− (<*) = unsafeBinaryOp "<"
302− (<=*) = unsafeBinaryOp "<="
351+(>*)
352+ :: Expression params tables ty
353+ -> Expression params tables ty
354+ -> Predicate params tables
355+(>*) = unsafeBinaryOp ">"
303356
304357{-----------------------------------------
305−table expressions
358+tables
306359-----------------------------------------}
307360
308−newtype TableExpression
361+newtype Table
309362 (params :: [ColumnType])
310363 (schema :: [(Symbol,[(Symbol,ColumnType)])])
311364 (columns :: [(Symbol,ColumnType)])
312− = UnsafeTableExpression { renderTableExpression :: ByteString }
365+ = UnsafeTable { renderTable :: ByteString }
313366 deriving (Show,Eq)
314367
315368class KnownSymbol table => HasTable table tables columns
316369 | table tables -> columns where
317− getTable :: Proxy# table -> TableExpression params tables columns
318− getTable table = UnsafeTableExpression $ fromString $ symbolVal' table
370+ getTable :: Proxy# table -> Table params tables columns
371+ getTable table = UnsafeTable $ fromString $ symbolVal' table
319372instance {-# OVERLAPPING #-} KnownSymbol table
320373 => HasTable table ((table ::: columns) ': tables) columns
321374instance {-# OVERLAPPABLE #-}
@@ -323,7 +376,7 @@ instance {-# OVERLAPPABLE #-}
323376 => HasTable table (table' ': schema) columns
324377
325378instance HasTable table schema columns
326− => IsLabel table (TableExpression params schema columns) where
379+ => IsLabel table (Table params schema columns) where
327380 fromLabel = getTable
328381
329382{-----------------------------------------
@@ -338,13 +391,13 @@ newtype Statement
338391 = UnsafeStatement { renderStatement :: ByteString }
339392 deriving (Show,Eq)
340393
341−newtype PreparedStatement
342− (params :: [ColumnType])
343− (columns :: [(Symbol,ColumnType)])
344− (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
345− (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
346− = UnsafePreparedStatement { renderPreparedStatement :: ByteString }
347− deriving (Show,Eq)
394+-- newtype PreparedStatement
395+-- (params :: [ColumnType])
396+-- (columns :: [(Symbol,ColumnType)])
397+-- (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
398+-- (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
399+-- = UnsafePreparedStatement { renderPreparedStatement :: ByteString }
400+-- deriving (Show,Eq)
348401
349402{-----------------------------------------
350403SELECT statements
@@ -352,71 +405,71 @@ SELECT statements
352405
353406data Join params schema tables where
354407 Table
355− :: Aliased (TableExpression params schema) table
408+ :: Aliased (Table params schema) table
356409 -> Join params schema '[table]
357410 Subselect
358411 :: Aliased (Selection params schema) table
359412 -> Join params schema '[table]
360413 Cross
361− :: Aliased (TableExpression params schema) table
414+ :: Aliased (Table params schema) table
362415 -> Join params schema tables
363416 -> Join params schema (table ': tables)
364417 Inner
365− :: Aliased (TableExpression params schema) table
366− -> Expression params (table ': tables) ('Required ('NotNull 'PGBool))
418+ :: Aliased (Table params schema) table
419+ -> Predicate params (table ': tables)
367420 -> Join params schema tables
368421 -> Join params schema (table ': tables)
369422 LeftOuter
370− :: Aliased (TableExpression params schema) right
371− -> Expression params '[left,right] ('Required ('NotNull 'PGBool))
423+ :: Aliased (Table params schema) right
424+ -> Predicate params '[left,right]
372425 -> Join params schema (tables)
373426 -> Join params schema (NullifyTable right ': left ': tables)
374427 RightOuter
375− :: Aliased (TableExpression params schema) right
376− -> Expression params '[left,right] ('Required ('NotNull 'PGBool))
428+ :: Aliased (Table params schema) right
429+ -> Predicate params '[left,right]
377430 -> Join params schema (left : tables)
378431 -> Join params schema (right ': NullifyTable left ': tables)
379432 FullOuter
380− :: Aliased (TableExpression params schema) right
381− -> Expression params '[left,right] ('Required ('NotNull 'PGBool))
433+ :: Aliased (Table params schema) right
434+ -> Predicate params '[left,right]
382435 -> Join params schema (left : tables)
383436 -> Join params schema
384437 (NullifyTable right ': NullifyTable left ': tables)
385438
386439renderJoin :: Join params schema tables -> ByteString
387440renderJoin = \case
388− Table table -> renderAliased renderTableExpression table
441+ Table table -> renderAliased renderTable table
389442 Subselect selection -> "SELECT " <> renderAliased renderSelection selection
390443 Cross table tables -> mconcat
391444 [ renderJoin tables
392445 , " CROSS JOIN "
393− , renderAliased renderTableExpression table
446+ , renderAliased renderTable table
394447 ]
395448 Inner table on tables -> mconcat
396449 [ renderJoin tables
397450 , " INNER JOIN "
398− , renderAliased renderTableExpression table
451+ , renderAliased renderTable table
399452 , " ON "
400453 , renderExpression on
401454 ]
402455 LeftOuter table on tables -> mconcat
403456 [ renderJoin tables
404457 , " LEFT OUTER JOIN "
405− , renderAliased renderTableExpression table
458+ , renderAliased renderTable table
406459 , " ON "
407460 , renderExpression on
408461 ]
409462 RightOuter table on tables -> mconcat
410463 [ renderJoin tables
411464 , " RIGHT OUTER JOIN "
412− , renderAliased renderTableExpression table
465+ , renderAliased renderTable table
413466 , " ON "
414467 , renderExpression on
415468 ]
416469 FullOuter table on tables -> mconcat
417470 [ renderJoin tables
418471 , " FULL OUTER JOIN "
419− , renderAliased renderTableExpression table
472+ , renderAliased renderTable table
420473 , " ON "
421474 , renderExpression on
422475 ]
@@ -425,78 +478,67 @@ instance HasTable table schema columns
425478 => IsLabel table (Join params schema '[table ::: columns]) where
426479 fromLabel p = Table $ fromLabel p
427480
428−data Clauses params tables = Clauses
429− { whereClause :: Maybe (Expression params tables ('Required ('NotNull 'PGBool)))
430− , limitClause :: Maybe (Expression params '[] ('Required ('NotNull 'PGInt8)))
431− , offsetClause :: Maybe (Expression params '[] ('Required ('NotNull 'PGInt8)))
432− }
433−
434−instance Monoid (Clauses params tables) where
435− mempty = Clauses Nothing Nothing Nothing
436− Clauses wh1 lim1 off1 `mappend` Clauses wh2 lim2 off2 = Clauses
437− { whereClause = case (wh1,wh2) of
438− (Nothing,Nothing) -> Nothing
439− (Just w1,Nothing) -> Just w1
440− (Nothing,Just w2) -> Just w2
441− (Just w1,Just w2) -> Just (w1 &&* w2)
442− , limitClause = case (lim1,lim2) of
443− (Nothing,Nothing) -> Nothing
444− (Just l1,Nothing) -> Just l1
445− (Nothing,Just l2) -> Just l2
446− (Just l1,Just l2) -> Just (l1 `minB` l2)
447− , offsetClause = case (off1,off2) of
448− (Nothing,Nothing) -> Nothing
449− (Just o1,Nothing) -> Just o1
450− (Nothing,Just o2) -> Just o2
451− (Just o1,Just o2) -> Just (o1 + o2)
452− }
453−
454−data From
481+data TableExpression
455482 (params :: [ColumnType])
456483 (schema :: [(Symbol,[(Symbol,ColumnType)])])
457484 (tables :: [(Symbol,[(Symbol,ColumnType)])])
458− = From
459− { fromJoin :: Join params schema tables
460− , fromClauses :: Clauses params tables
485+ = TableExpression
486+ { joinClause :: Join params schema tables
487+ , whereClause :: [Predicate params tables]
488+ , limitClause :: [Expression params '[] ('Required ('NotNull 'PGInt8))]
489+ , offsetClause :: [Expression params '[] ('Required ('NotNull 'PGInt8))]
461490 }
462491
463−join
464− :: Join params schema tables
465− -> From params schema tables
466−join tables = From tables mempty
467−
468−renderFrom :: From params schema tables -> ByteString
469−renderFrom (From tref (Clauses wh lim off))= mconcat
470− [ renderJoin tref
471− , maybe "" ((" WHERE " <>) . renderExpression) wh
472− , maybe "" ((" LIMIT " <>) . renderExpression) lim
473− , maybe "" ((" OFFSET " <>) . renderExpression) off
474− ]
492+renderTableExpression :: TableExpression params schema tables -> ByteString
493+renderTableExpression (TableExpression tables whs' lims' offs') = mconcat
494+ [ renderJoin tables
495+ , renderWheres whs'
496+ , renderLimits lims'
497+ , renderOffsets offs'
498+ ] where
499+ renderWheres = \case
500+ [] -> ""
501+ wh:[] -> " WHERE " <> renderExpression wh
502+ wh:whs -> " WHERE " <> renderExpression (foldr (&&*) wh whs)
503+ renderLimits = \case
504+ [] -> ""
505+ lim:[] -> " LIMIT " <> renderExpression lim
506+ lims -> mconcat
507+ [ " LIMIT LEAST("
508+ , ByteString.intercalate ", " (renderExpression <$> reverse lims)
509+ , ")"
510+ ]
511+ renderOffsets = \case
512+ [] -> ""
513+ off:[] -> " OFFSET " <> renderExpression off
514+ off:offs -> " OFFSET " <> renderExpression (foldr (+) off offs)
475515
476516instance (HasTable table schema columns, table ~ table')
477− => IsLabel table (From params schema '[table' ::: columns]) where
478− fromLabel p = From (fromLabel p) mempty
517+ => IsLabel table (TableExpression params schema '[table' ::: columns]) where
518+ fromLabel p = join (fromLabel p)
519+
520+join
521+ :: Join params schema tables
522+ -> TableExpression params schema tables
523+join tables = TableExpression tables [] [] []
479524
480525where_
481− :: Expression params tables ('Required ('NotNull 'PGBool))
482− -> From params schema tables
483− -> From params schema tables
484−where_ wh (From tabs fromClauses1) = From tabs
485− (fromClauses1 <> Clauses (Just wh) Nothing Nothing)
526+ :: Predicate params tables
527+ -> TableExpression params schema tables
528+ -> TableExpression params schema tables
529+where_ wh (TableExpression tabs whs lims offs) = TableExpression tabs (wh:whs) lims offs
486530
487531limit
488532 :: Expression params '[] ('Required ('NotNull 'PGInt8))
489− -> From params schema tables
490− -> From params schema tables
491−limit lim (From tabs fromClauses1) = From tabs
492− (fromClauses1 <> Clauses Nothing (Just lim) Nothing)
533+ -> TableExpression params schema tables
534+ -> TableExpression params schema tables
535+limit lim (TableExpression tabs whs lims offs) = TableExpression tabs whs (lim:lims) offs
493536
494537offset
495538 :: Expression params '[] ('Required ('NotNull 'PGInt8))
496− -> From params schema tables
497− -> From params schema tables
498−offset off (From tabs fromClauses1) = From tabs
499− (fromClauses1 <> Clauses Nothing Nothing (Just off))
539+ -> TableExpression params schema tables
540+ -> TableExpression params schema tables
541+offset off (TableExpression tabs whs lims offs) = TableExpression tabs whs lims (off:offs)
500542
501543newtype Selection
502544 (params :: [ColumnType])
@@ -507,25 +549,25 @@ newtype Selection
507549
508550starFrom
509551 :: tables ~ '[table ::: columns]
510− => From params schema tables
552+ => TableExpression params schema tables
511553 -> Selection params schema columns
512−starFrom tabs = UnsafeSelection $ "* FROM " <> renderFrom tabs
554+starFrom tabs = UnsafeSelection $ "* FROM " <> renderTableExpression tabs
513555
514556dotStarFrom
515557 :: HasTable table tables columns
516558 => Alias table
517− -> From params schema tables
559+ -> TableExpression params schema tables
518560 -> Selection params schema columns
519561Alias tab `dotStarFrom` tabs = UnsafeSelection $
520− fromString (symbolVal' tab) <> ".* FROM " <> renderFrom tabs
562+ fromString (symbolVal' tab) <> ".* FROM " <> renderTableExpression tabs
521563
522564from
523565 :: SListI columns
524566 => NP (Aliased (Expression params tables)) columns
525− -> From params schema tables
567+ -> TableExpression params schema tables
526568 -> Selection params schema columns
527569list `from` tabs = UnsafeSelection $
528− renderList list <> " FROM " <> renderFrom tabs
570+ renderList list <> " FROM " <> renderTableExpression tabs
529571 where
530572 renderList
531573 = ByteString.intercalate ", "
@@ -539,34 +581,8 @@ select = UnsafeStatement . ("SELECT " <>) . (<> ";") . renderSelection
539581
540582subselect
541583 :: Aliased (Selection params schema) table
542− -> From params schema '[table]
543−subselect selection = From
544− { fromJoin = Subselect selection
545− , fromClauses = mempty
546− }
547−
548−{-----------------------------------------
549−INSERT statements
550−-----------------------------------------}
551−
552−insertInto
553− :: (SListI columns, HasTable table schema columns)
554− => Alias table
555− -> NP (Aliased (Expression params '[])) columns
556− -> Statement params '[] schema schema
557−insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
558− <> fromString (symbolVal' table)
559− <> " (" <> ByteString.intercalate ", " aliases
560− <> ") VALUES ("
561− <> ByteString.intercalate ", " values
562− <> ");"
563− where
564− aliases = hcollapse $ hmap
565− (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
566− expressions
567− values = hcollapse $ hmap
568− (\ (expression `As` _) -> K (renderExpression expression))
569− expressions
584+ -> TableExpression params schema '[table]
585+subselect selection = join (Subselect selection)
570586
571587{-----------------------------------------
572588CREATE statements
@@ -732,37 +748,189 @@ instance {-# OVERLAPPABLE #-}
732748 DropTable table schema0 schema1
733749 => DropTable table (table' ': schema0) (table' ': schema1)
734750
751+{-----------------------------------------
752+INSERT statements
753+-----------------------------------------}
754+
755+insertInto
756+ :: (SListI columns, HasTable table schema columns)
757+ => Alias table
758+ -> NP (Aliased (Expression params '[])) columns
759+ -> Statement params '[] schema schema
760+insertInto (Alias table) expressions = UnsafeStatement $ "INSERT INTO "
761+ <> fromString (symbolVal' table)
762+ <> " (" <> ByteString.intercalate ", " aliases
763+ <> ") VALUES ("
764+ <> ByteString.intercalate ", " values
765+ <> ");"
766+ where
767+ aliases = hcollapse $ hmap
768+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
769+ expressions
770+ values = hcollapse $ hmap
771+ (\ (expression `As` _) -> K (renderExpression expression))
772+ expressions
773+
774+insertIntoReturning
775+ :: (SListI columns, SListI results, HasTable table schema columns)
776+ => Alias table
777+ -> NP (Aliased (Expression params '[])) columns
778+ -> NP (Aliased (Expression params '[table ::: columns])) results
779+ -> Statement params results schema schema
780+insertIntoReturning (Alias table) inserts results
781+ = UnsafeStatement . mconcat $
782+ [ "INSERT INTO "
783+ , fromString (symbolVal' table)
784+ , " (" <> ByteString.intercalate ", " aliases
785+ , ") VALUES ("
786+ , ByteString.intercalate ", " values
787+ , ") RETURNING "
788+ , renderList results
789+ , ";"
790+ ]
791+ where
792+ aliases = hcollapse $ hmap
793+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
794+ inserts
795+ values = hcollapse $ hmap
796+ (\ (expression `As` _) -> K (renderExpression expression))
797+ inserts
798+ renderList
799+ = ByteString.intercalate ", "
800+ . hcollapse
801+ . hmap (K . renderAliased renderExpression)
802+
735803{-----------------------------------------
736804UPDATE statements
737805-----------------------------------------}
738806
739−set :: g x -> (Maybe :.: g) x
807+set :: Expression params tables x -> (Maybe :.: Expression params tables) x
740808set = Comp . Just
741809
742−same :: (Maybe :.: g) x
810+same :: (Maybe :.: Expression params tables) x
743811same = Comp Nothing
744812
813+renderSet
814+ :: Aliased (Maybe :.: Expression params '[table ::: columns]) column
815+ -> Maybe ByteString
816+renderSet = \case
817+ Comp (Just expression) `As` Alias column -> Just $ mconcat
818+ [ fromString $ symbolVal' column
819+ , " = "
820+ , renderExpression expression
821+ ]
822+ Comp Nothing `As` _ -> Nothing
823+
745824update
746825 :: (HasTable table schema columns, SListI columns)
747826 => Alias table
748827 -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns
749− -> Expression params '[table ::: columns] ('Required ('NotNull 'PGBool))
828+ -> Predicate params '[table ::: columns]
750829 -> Statement params '[] schema schema
751−update (Alias table) columns where' = UnsafeStatement $ mconcat
830+update (Alias table) columns wh = UnsafeStatement $ mconcat
752831 [ "UPDATE "
753832 , fromString $ symbolVal' table
754833 , " SET "
755834 , ByteString.intercalate ", " . catMaybes . hcollapse $
756835 hmap (K . renderSet) columns
757− , " WHERE ", renderExpression where'
836+ , " WHERE ", renderExpression wh, ";"
837+ ]
838+
839+updateReturning
840+ :: (SListI columns, SListI results, HasTable table schema columns)
841+ => Alias table
842+ -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns
843+ -> Predicate params '[table ::: columns]
844+ -> NP (Aliased (Expression params '[table ::: columns])) results
845+ -> Statement params results schema schema
846+updateReturning (Alias table) updates wh results = UnsafeStatement $ mconcat
847+ [ "UPDATE "
848+ , fromString $ symbolVal' table
849+ , " SET "
850+ , ByteString.intercalate ", " . catMaybes . hcollapse $
851+ hmap (K . renderSet) updates
852+ , " WHERE ", renderExpression wh
853+ , " RETURNING ", renderList results
854+ , ";"
855+ ]
856+ where
857+ renderList
858+ = ByteString.intercalate ", "
859+ . hcollapse
860+ . hmap (K . renderAliased renderExpression)
861+
862+upsertInto
863+ :: (SListI columns, HasTable table schema columns)
864+ => Alias table
865+ -> NP (Aliased (Expression params '[])) columns
866+ -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns
867+ -> Predicate params '[table ::: columns]
868+ -> Statement params '[] schema schema
869+upsertInto (Alias table) inserts updates wh = UnsafeStatement . mconcat $
870+ [ "INSERT INTO "
871+ , fromString (symbolVal' table)
872+ , " (" <> ByteString.intercalate ", " aliases
873+ , ") VALUES ("
874+ , ByteString.intercalate ", " values
875+ , ") ON CONFLICT UPDATE "
876+ , fromString $ symbolVal' table
877+ , " SET "
878+ , ByteString.intercalate ", " . catMaybes . hcollapse $
879+ hmap (K . renderSet) updates
880+ , " WHERE ", renderExpression wh, ";"
758881 ] where
759− renderSet
760− :: Aliased (Maybe :.: Expression params tables) column
761− -> Maybe ByteString
762− renderSet = \case
763− Comp (Just expression) `As` Alias column -> Just $ mconcat
764− [ fromString $ symbolVal' column
765− , " = "
766− , renderExpression expression
767− ]
768− Comp Nothing `As` _ -> Nothing
882+ aliases = hcollapse $ hmap
883+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
884+ inserts
885+ values = hcollapse $ hmap
886+ (\ (expression `As` _) -> K (renderExpression expression))
887+ inserts
888+
889+upsertIntoReturning
890+ :: (SListI columns, SListI results, HasTable table schema columns)
891+ => Alias table
892+ -> NP (Aliased (Expression params '[])) columns
893+ -> NP (Aliased (Maybe :.: Expression params '[table ::: columns])) columns
894+ -> Predicate params '[table ::: columns]
895+ -> NP (Aliased (Expression params '[table ::: columns])) results
896+ -> Statement params results schema schema
897+upsertIntoReturning (Alias table) inserts updates wh results = UnsafeStatement . mconcat $
898+ [ "INSERT INTO "
899+ , fromString (symbolVal' table)
900+ , " (" <> ByteString.intercalate ", " aliases
901+ , ") VALUES ("
902+ , ByteString.intercalate ", " values
903+ , ") ON CONFLICT UPDATE "
904+ , fromString $ symbolVal' table
905+ , " SET "
906+ , ByteString.intercalate ", " . catMaybes . hcollapse $
907+ hmap (K . renderSet) updates
908+ , " WHERE ", renderExpression wh
909+ , " RETURNING ", renderList results
910+ , ";"
911+ ] where
912+ aliases = hcollapse $ hmap
913+ (\ (_ `As` Alias name) -> K (fromString (symbolVal' name)))
914+ inserts
915+ values = hcollapse $ hmap
916+ (\ (expression `As` _) -> K (renderExpression expression))
917+ inserts
918+ renderList
919+ = ByteString.intercalate ", "
920+ . hcollapse
921+ . hmap (K . renderAliased renderExpression)
922+
923+{-----------------------------------------
924+DELETE statements
925+-----------------------------------------}
926+
927+deleteFrom
928+ :: (HasTable table schema columns, SListI columns)
929+ => Alias table
930+ -> Predicate params '[table ::: columns]
931+ -> Statement params '[] schema schema
932+deleteFrom (Alias table) wh = UnsafeStatement $ mconcat
933+ [ "DELETE FROM "
934+ , fromString $ symbolVal' table
935+ , " WHERE ", renderExpression wh, ";"
936+ ]
squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+58−11
@@ -8,7 +8,6 @@
88
99module Squeel.PostgreSQL.StatementSpec where
1010
11−import Data.Boolean
1211import Data.Function
1312import Generics.SOP hiding (from)
1413import Test.Hspec
@@ -25,9 +24,9 @@ spec = do
2524 statement :: Statement '[] SumAndCol1 Tables Tables
2625 statement = select $
2726 ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
28− `from` (#table1 & where_ true)
27+ `from` (#table1 & where_ (#col1 >* #col2))
2928 statement `shouldRenderAs`
30− "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE TRUE;"
29+ "SELECT (col1 + col2) AS sum, col1 AS col1 FROM table1 AS table1 WHERE (col1 > col2);"
3130 it "combines WHEREs using AND" $ do
3231 let
3332 statement :: Statement '[] SumAndCol1 Tables Tables
@@ -53,7 +52,7 @@ spec = do
5352 statement :: Statement '[] Columns Tables Tables
5453 statement = select $ starFrom (#table1 & limit 1 & limit 2)
5554 statement `shouldRenderAs`
56− "SELECT * FROM table1 AS table1 LIMIT CASE WHEN (1 <= 2) THEN 1 ELSE 2 END;"
55+ "SELECT * FROM table1 AS table1 LIMIT LEAST(1, 2);"
5756 it "should render parameters using $ signs" $ do
5857 let
5958 statement :: Statement '[ 'Required ('NotNull 'PGInt8)] Columns Tables Tables
@@ -69,12 +68,60 @@ spec = do
6968 statement :: Statement '[] Columns Tables Tables
7069 statement = select $ starFrom (#table1 & offset 1 & offset 2)
7170 statement `shouldRenderAs` "SELECT * FROM table1 AS table1 OFFSET (1 + 2);"
72− it "correctly render simple INSERTs" $ do
71+ it "correctly renders simple INSERTs" $ do
7372 let
7473 statement :: Statement '[] '[] Tables Tables
7574 statement = insertInto #table1 $ 2 `As` #col1 :* 4 `As` #col2 :* Nil
7675 statement `shouldRenderAs`
7776 "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
77+ it "correctly renders returning INSERTs" $ do
78+ let
79+ statement :: Statement '[] SumAndCol1 Tables Tables
80+ statement = insertIntoReturning #table1
81+ (2 `As` #col1 :* 4 `As` #col2 :* Nil)
82+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
83+ statement `shouldRenderAs`
84+ "INSERT INTO table1 (col1, col2) VALUES (2, 4) RETURNING (col1 + col2) AS sum, col1 AS col1;"
85+ it "correctly renders simple UPDATEs" $ do
86+ let
87+ statement :: Statement '[] '[] Tables Tables
88+ statement = update #table1 (set 2 `As` #col1 :* same `As` #col2 :* Nil) (#col1 /=* #col2)
89+ statement `shouldRenderAs`
90+ "UPDATE table1 SET col1 = 2 WHERE (col1 <> col2);"
91+ it "correctly renders returning UPDATEs" $ do
92+ let
93+ statement :: Statement '[] SumAndCol1 Tables Tables
94+ statement = updateReturning #table1
95+ (set 2 `As` #col1 :* same `As` #col2 :* Nil)
96+ (#col1 /=* #col2)
97+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
98+ statement `shouldRenderAs`
99+ "UPDATE table1 SET col1 = 2 WHERE (col1 <> col2) RETURNING (col1 + col2) AS sum, col1 AS col1;"
100+ it "correctly renders upsert INSERTs" $ do
101+ let
102+ statement :: Statement '[] '[] Tables Tables
103+ statement = upsertInto #table1
104+ (2 `As` #col1 :* 4 `As` #col2 :* Nil)
105+ (set 2 `As` #col1 :* same `As` #col2 :* Nil)
106+ (#col1 /=* #col2)
107+ statement `shouldRenderAs`
108+ "INSERT INTO table1 (col1, col2) VALUES (2, 4) ON CONFLICT UPDATE table1 SET col1 = 2 WHERE (col1 <> col2);"
109+ it "correctly renders returning upsert INSERTs" $ do
110+ let
111+ statement :: Statement '[] SumAndCol1 Tables Tables
112+ statement = upsertIntoReturning #table1
113+ (2 `As` #col1 :* 4 `As` #col2 :* Nil)
114+ (set 2 `As` #col1 :* same `As` #col2 :* Nil)
115+ (#col1 /=* #col2)
116+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
117+ statement `shouldRenderAs`
118+ "INSERT INTO table1 (col1, col2) VALUES (2, 4) ON CONFLICT UPDATE table1 SET col1 = 2 WHERE (col1 <> col2) RETURNING (col1 + col2) AS sum, col1 AS col1;"
119+ it "correctly renders DELETEs" $ do
120+ let
121+ statement :: Statement '[] '[] Tables Tables
122+ statement = deleteFrom #table1 (#col1 ==* #col2)
123+ statement `shouldRenderAs`
124+ "DELETE FROM table1 WHERE (col1 = col2);"
78125 it "should be safe against SQL injection in literal text" $ do
79126 let
80127 statement :: Statement '[] '[] StudentsTable StudentsTable
@@ -85,9 +132,9 @@ spec = do
85132 describe "JOINs" $ do
86133 let
87134 vals =
88− #orders &. #orderVal `As` #orderVal
89− :* #customers &. #customerVal `As` #customerVal
90− :* #shippers &. #shipperVal `As` #shipperVal :* Nil
135+ (#orders &. #orderVal) `As` #orderVal
136+ :* (#customers &. #customerVal) `As` #customerVal
137+ :* (#shippers &. #shipperVal) `As` #shipperVal :* Nil
91138 it "should render CROSS JOINs" $ do
92139 let
93140 statement :: Statement '[] ValueColumns JoinTables JoinTables
@@ -103,13 +150,13 @@ spec = do
103150 \ CROSS JOIN shippers AS shippers;"
104151 it "should render INNER JOINs" $ do
105152 let
106− innerJoins :: From '[] JoinTables JoinTables
153+ innerJoins :: TableExpression '[] JoinTables JoinTables
107154 innerJoins = join $
108155 #orders
109156 & Inner #customers
110− (#orders &. #customerID ==* #customers &. #customerID)
157+ ((#orders &. #customerID) ==* (#customers &. #customerID))
111158 & Inner #shippers
112− (#orders &. #shipperID ==* #shippers &. #shipperID)
159+ ((#orders &. #shipperID) ==* (#shippers &. #shipperID))
113160 selection :: Statement '[] ValueColumns JoinTables JoinTables
114161 selection = select $ vals `from` innerJoins
115162 selection `shouldRenderAs`
squeel-postgresql/test/Squeel/PostgreSQL/ValueSpec.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Squeel.PostgreSQL.ValueSpec where
2−
3−import Test.Hspec
4−
5−spec :: Spec
6−spec = return ()