@@ -1,1447 +0,0 @@
1−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2−{-# LANGUAGE
3− DataKinds
4− , DeriveGeneric
5− , DeriveDataTypeable
6− , FlexibleContexts
7− , FlexibleInstances
8− , FunctionalDependencies
9− , GADTs
10− , GeneralizedNewtypeDeriving
11− , LambdaCase
12− , MagicHash
13− , OverloadedStrings
14− , PolyKinds
15− , RankNTypes
16− , ScopedTypeVariables
17− , StandaloneDeriving
18− , TypeApplications
19− , TypeFamilies
20− , TypeOperators
21− , UndecidableInstances
22−#-}
23−
24−module Squeal.PostgreSQL.Statement where
25−
26−import Control.Category
27−import Control.DeepSeq
28−import Data.ByteString (ByteString)
29−import Data.Data (Data)
30−import Data.Foldable
31−import Data.Maybe
32−import Data.Monoid hiding (All)
33−import Data.Ratio
34−import Data.String
35−import Data.Word
36−import Generics.SOP
37−import GHC.Exts
38−import GHC.OverloadedLabels
39−import GHC.TypeLits
40−import Prelude hiding (RealFrac(..), id, (.))
41−
42−import qualified GHC.Generics as GHC
43−import qualified Data.ByteString as ByteString
44−
45−import Squeal.PostgreSQL.Schema
46−
47−{-----------------------------------------
48−column expressions
49−-----------------------------------------}
50−
51−newtype Expression
52− (params :: [ColumnType])
53− (tables :: [(Symbol,[(Symbol,ColumnType)])])
54− (grouping :: Grouping)
55− (ty :: ColumnType)
56− = UnsafeExpression { renderExpression :: ByteString }
57− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
58−
59−class (PGTyped (BaseType ty), KnownNat n)
60− => HasParameter (n :: Nat) params ty | n params -> ty where
61− param :: proxy n -> Expression params tables grouping ty
62− param _ = UnsafeExpression $ parenthesized $
63− "$" <> renderNat (Proxy @n) <+> "::"
64− <+> renderTypeExpression (pgtype @(BaseType ty))
65−instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)
66− => HasParameter 1 (ty1:tys) ty1
67−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
68− => HasParameter n (ty' : params) ty
69−
70−class KnownSymbol column => HasColumn column columns ty
71− | column columns -> ty where
72− getColumn
73− :: Alias column
74− -> Expression params '[table ::: columns] 'Ungrouped ty
75− getColumn column = UnsafeExpression $ renderAlias column
76−instance {-# OVERLAPPING #-} KnownSymbol column
77− => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)
78−instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
79− => HasColumn column (ty' ': table) ty
80−
81−instance (HasColumn column columns ty, tables ~ '[table ::: columns])
82− => IsLabel column (Expression params tables 'Ungrouped ty) where
83− fromLabel = getColumn (Alias @column)
84−
85−instance (HasTable table tables columns, HasColumn column columns ty)
86− => IsTableColumn table column (Expression params tables 'Ungrouped ty) where
87− table ! column = UnsafeExpression $
88− renderAlias table <> "." <> renderAlias column
89−
90−data Column
91− (columns :: [(Symbol,ColumnType)])
92− (columnty :: (Symbol,ColumnType))
93− where
94− Column
95− :: HasColumn column columns ty
96− => Alias column
97− -> Column columns (column ::: ty)
98−deriving instance Show (Column columns columnty)
99−deriving instance Eq (Column columns columnty)
100−deriving instance Ord (Column columns columnty)
101−
102−def :: Expression params '[] 'Ungrouped ('Optional (nullity ty))
103−def = UnsafeExpression "DEFAULT"
104−
105−unDef
106− :: Expression params '[] 'Ungrouped ('Required (nullity ty))
107− -> Expression params '[] 'Ungrouped ('Optional (nullity ty))
108−unDef = UnsafeExpression . renderExpression
109−
110−null :: Expression params tables grouping (optionality ('Null ty))
111−null = UnsafeExpression "NULL"
112−
113−unNull
114− :: Expression params tables grouping (optionality ('NotNull ty))
115− -> Expression params tables grouping (optionality ('Null ty))
116−unNull = UnsafeExpression . renderExpression
117−
118−coalesce
119− :: [Expression params tables grouping ('Required ('Null ty))]
120− -> Expression params tables grouping ('Required ('NotNull ty))
121− -> Expression params tables grouping ('Required ('NotNull ty))
122−coalesce nullxs notNullx = UnsafeExpression $
123− "COALESCE" <> parenthesized (commaSeparated
124− ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
125−
126−fromNull
127− :: Expression params tables grouping ('Required ('NotNull ty))
128− -> Expression params tables grouping ('Required ('Null ty))
129− -> Expression params tables grouping ('Required ('NotNull ty))
130−fromNull notNullx nullx = coalesce [nullx] notNullx
131−
132−isNull
133− :: Expression params tables grouping ('Required ('Null ty))
134− -> Condition params tables grouping
135−isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
136−
137−isn'tNull
138− :: Expression params tables grouping ('Required ('Null ty))
139− -> Condition params tables grouping
140−isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
141−
142−matchNull
143− :: Expression params tables grouping ('Required nullty)
144− -> ( Expression params tables grouping ('Required ('NotNull ty))
145− -> Expression params tables grouping ('Required nullty) )
146− -> Expression params tables grouping ('Required ('Null ty))
147− -> Expression params tables grouping ('Required nullty)
148−matchNull y f x = ifThenElse (isNull x) y
149− (f (UnsafeExpression (renderExpression y)))
150−
151−nullIf
152− :: Expression params tables grouping ('Required ('NotNull ty))
153− -> Expression params tables grouping ('Required ('NotNull ty))
154− -> Expression params tables grouping ('Required ('Null ty))
155−nullIf x y = UnsafeExpression $ parenthesized $
156− renderExpression x <> ", " <> renderExpression y
157−
158−greatest
159− :: [Expression params tables grouping ('Required nullty)]
160− -> Expression params table grouping ('Required nullty)
161−greatest xs = UnsafeExpression $ "GREATEST("
162− <> commaSeparated (renderExpression <$> xs) <> ")"
163−
164−least
165− :: [Expression params tables grouping ('Required nullty)]
166− -> Expression params table grouping ('Required nullty)
167−least xs = UnsafeExpression $ "LEAST("
168− <> commaSeparated (renderExpression <$> xs) <> ")"
169−
170−unsafeBinaryOp
171− :: ByteString
172− -> Expression params tables grouping ('Required ty0)
173− -> Expression params tables grouping ('Required ty1)
174− -> Expression params tables grouping ('Required ty2)
175−unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
176− renderExpression x <+> op <+> renderExpression y
177−
178−unsafeUnaryOp
179− :: ByteString
180− -> Expression params tables grouping ('Required ty0)
181− -> Expression params tables grouping ('Required ty1)
182−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
183− op <+> renderExpression x
184−
185−unsafeFunction
186− :: ByteString
187− -> Expression params tables grouping ('Required xty)
188− -> Expression params tables grouping ('Required yty)
189−unsafeFunction fun x = UnsafeExpression $
190− fun <> parenthesized (renderExpression x)
191−
192−instance PGNum ty
193− => Num (Expression params tables grouping ('Required (nullity ty))) where
194− (+) = unsafeBinaryOp "+"
195− (-) = unsafeBinaryOp "-"
196− (*) = unsafeBinaryOp "*"
197− abs = unsafeFunction "abs"
198− signum = unsafeFunction "sign"
199− fromInteger
200− = UnsafeExpression
201− . (<> if decimal (Proxy :: Proxy ty) then "." else "")
202− . fromString
203− . show
204−
205−instance PGFloating ty => Fractional
206− (Expression params tables grouping ('Required (nullity ty))) where
207− (/) = unsafeBinaryOp "/"
208− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
209−
210−instance (PGFloating ty, PGTyped ty) => Floating
211− (Expression params tables grouping ('Required (nullity ty))) where
212− pi = UnsafeExpression "pi()"
213− exp = unsafeFunction "exp"
214− log = unsafeFunction "ln"
215− sqrt = unsafeFunction "sqrt"
216− b ** x = UnsafeExpression $
217− "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"
218− logBase b y = cast pgtype $ logBaseNumeric b y
219− where
220− logBaseNumeric
221− :: Expression params tables grouping ('Required (nullity ty))
222− -> Expression params tables grouping ('Required (nullity ty))
223− -> Expression params tables grouping ('Required (nullity 'PGnumeric))
224− logBaseNumeric b' y' = UnsafeExpression $ mconcat
225− [ "log("
226− , renderExpression (cast numeric b')
227− , ", "
228− , renderExpression (cast numeric y')
229− , ")"
230− ]
231− sin = unsafeFunction "sin"
232− cos = unsafeFunction "cos"
233− tan = unsafeFunction "tan"
234− asin = unsafeFunction "asin"
235− acos = unsafeFunction "acos"
236− atan = unsafeFunction "atan"
237− sinh x = (exp x - exp (-x)) / 2
238− cosh x = (exp x + exp (-x)) / 2
239− tanh x = sinh x / cosh x
240− asinh x = log (x + sqrt (x*x + 1))
241− acosh x = log (x + sqrt (x*x - 1))
242− atanh x = log ((1 + x) / (1 - x)) / 2
243−
244−atan2
245− :: PGFloating float
246− => Expression params tables grouping ('Required (nullity float))
247− -> Expression params tables grouping ('Required (nullity float))
248− -> Expression params tables grouping ('Required (nullity float))
249−atan2 y x = UnsafeExpression $
250− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
251−
252−cast
253− :: TypeExpression ('Required ('Null ty1))
254− -> Expression params tables grouping ('Required (nullity ty0))
255− -> Expression params tables grouping ('Required (nullity ty1))
256−cast ty x = UnsafeExpression $ parenthesized $
257− renderExpression x <+> "::" <+> renderTypeExpression ty
258−
259−div
260− :: PGIntegral int
261− => Expression params tables grouping ('Required (nullity int))
262− -> Expression params tables grouping ('Required (nullity int))
263− -> Expression params tables grouping ('Required (nullity int))
264−div = unsafeBinaryOp "/"
265−
266−mod
267− :: PGIntegral int
268− => Expression params tables grouping ('Required (nullity int))
269− -> Expression params tables grouping ('Required (nullity int))
270− -> Expression params tables grouping ('Required (nullity int))
271−mod = unsafeBinaryOp "%"
272−
273−trunc
274− :: PGFloating frac
275− => Expression params tables grouping ('Required (nullity frac))
276− -> Expression params tables grouping ('Required (nullity frac))
277−trunc = unsafeFunction "trunc"
278−
279−round_
280− :: PGFloating frac
281− => Expression params tables grouping ('Required (nullity frac))
282− -> Expression params tables grouping ('Required (nullity frac))
283−round_ = unsafeFunction "round"
284−
285−ceiling_
286− :: PGFloating frac
287− => Expression params tables grouping ('Required (nullity frac))
288− -> Expression params tables grouping ('Required (nullity frac))
289−ceiling_ = unsafeFunction "ceiling"
290−
291−instance IsString
292− (Expression params tables grouping ('Required (nullity 'PGtext))) where
293− fromString str = UnsafeExpression $
294− "E\'" <> fromString (escape =<< str) <> "\'"
295− where
296− escape = \case
297− '\NUL' -> "\\0"
298− '\'' -> "''"
299− '"' -> "\\\""
300− '\b' -> "\\b"
301− '\n' -> "\\n"
302− '\r' -> "\\r"
303− '\t' -> "\\t"
304− '\\' -> "\\\\"
305− c -> [c]
306−
307−type Condition params tables grouping =
308− Expression params tables grouping ('Required ('NotNull 'PGbool))
309−
310−true :: Condition params tables grouping
311−true = UnsafeExpression "TRUE"
312−
313−false :: Condition params tables grouping
314−false = UnsafeExpression "FALSE"
315−
316−not_
317− :: Condition params tables grouping
318− -> Condition params tables grouping
319−not_ = unsafeUnaryOp "NOT"
320−
321−(&&*)
322− :: Condition params tables grouping
323− -> Condition params tables grouping
324− -> Condition params tables grouping
325−(&&*) = unsafeBinaryOp "AND"
326−
327−(||*)
328− :: Condition params tables grouping
329− -> Condition params tables grouping
330− -> Condition params tables grouping
331−(||*) = unsafeBinaryOp "OR"
332−
333−caseWhenThenElse
334− :: [ ( Condition params tables grouping
335− , Expression params tables grouping ('Required ty)
336− ) ]
337− -> Expression params tables grouping ('Required ty)
338− -> Expression params tables grouping ('Required ty)
339−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
340− [ "CASE"
341− , mconcat
342− [ mconcat
343− [ " WHEN ", renderExpression when_
344− , " THEN ", renderExpression then_
345− ]
346− | (when_,then_) <- whenThens
347− ]
348− , " ELSE ", renderExpression else_
349− , " END"
350− ]
351−
352−ifThenElse
353− :: Condition params tables grouping
354− -> Expression params tables grouping ('Required ty)
355− -> Expression params tables grouping ('Required ty)
356− -> Expression params tables grouping ('Required ty)
357−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
358−
359−(==*)
360− :: Expression params tables grouping ('Required (nullity ty))
361− -> Expression params tables grouping ('Required (nullity ty))
362− -> Expression params tables grouping ('Required (nullity 'PGbool))
363−(==*) = unsafeBinaryOp "="
364−infix 4 ==*
365−
366−(/=*)
367− :: Expression params tables grouping ('Required (nullity ty))
368− -> Expression params tables grouping ('Required (nullity ty))
369− -> Expression params tables grouping ('Required (nullity 'PGbool))
370−(/=*) = unsafeBinaryOp "<>"
371−infix 4 /=*
372−
373−(>=*)
374− :: Expression params tables grouping ('Required (nullity ty))
375− -> Expression params tables grouping ('Required (nullity ty))
376− -> Expression params tables grouping ('Required (nullity 'PGbool))
377−(>=*) = unsafeBinaryOp ">="
378−infix 4 >=*
379−
380−(<*)
381− :: Expression params tables grouping ('Required (nullity ty))
382− -> Expression params tables grouping ('Required (nullity ty))
383− -> Expression params tables grouping ('Required (nullity 'PGbool))
384−(<*) = unsafeBinaryOp "<"
385−infix 4 <*
386−
387−(<=*)
388− :: Expression params tables grouping ('Required (nullity ty))
389− -> Expression params tables grouping ('Required (nullity ty))
390− -> Expression params tables grouping ('Required (nullity 'PGbool))
391−(<=*) = unsafeBinaryOp "<="
392−infix 4 <=*
393−
394−(>*)
395− :: Expression params tables grouping ('Required (nullity ty))
396− -> Expression params tables grouping ('Required (nullity ty))
397− -> Expression params tables grouping ('Required (nullity 'PGbool))
398−(>*) = unsafeBinaryOp ">"
399−infix 4 >*
400−
401−currentDate
402− :: Expression params tables grouping ('Required (nullity 'PGdate))
403−currentDate = UnsafeExpression "CURRENT_DATE"
404−
405−currentTime
406− :: Expression params tables grouping ('Required (nullity 'PGtimetz))
407−currentTime = UnsafeExpression "CURRENT_TIME"
408−
409−currentTimestamp
410− :: Expression params tables grouping ('Required (nullity 'PGtimestamptz))
411−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
412−
413−localTime
414− :: Expression params tables grouping ('Required (nullity 'PGtime))
415−localTime = UnsafeExpression "LOCALTIME"
416−
417−localTimestamp
418− :: Expression params tables grouping ('Required (nullity 'PGtimestamp))
419−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
420−
421−data SortExpression params tables grouping where
422− Asc
423− :: Expression params tables grouping ('Required ('NotNull ty))
424− -> SortExpression params tables grouping
425− Desc
426− :: Expression params tables grouping ('Required ('NotNull ty))
427− -> SortExpression params tables grouping
428− AscNullsFirst
429− :: Expression params tables grouping ('Required ('Null ty))
430− -> SortExpression params tables grouping
431− AscNullsLast
432− :: Expression params tables grouping ('Required ('Null ty))
433− -> SortExpression params tables grouping
434− DescNullsFirst
435− :: Expression params tables grouping ('Required ('Null ty))
436− -> SortExpression params tables grouping
437− DescNullsLast
438− :: Expression params tables grouping ('Required ('Null ty))
439− -> SortExpression params tables grouping
440−deriving instance Show (SortExpression params tables grouping)
441−
442−renderSortExpression :: SortExpression params tables grouping -> ByteString
443−renderSortExpression = \case
444− Asc expression -> renderExpression expression <+> "ASC"
445− Desc expression -> renderExpression expression <+> "DESC"
446− AscNullsFirst expression -> renderExpression expression
447− <+> "ASC NULLS FIRST"
448− DescNullsFirst expression -> renderExpression expression
449− <+> "DESC NULLS FIRST"
450− AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"
451− DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"
452−
453−
454−{-----------------------------------------
455−aggregation
456−-----------------------------------------}
457−
458−data By
459− (tables :: [(Symbol,[(Symbol,ColumnType)])])
460− (by :: (Symbol,Symbol)) where
461− By
462− :: (tables ~ '[table ::: columns], HasColumn column columns ty)
463− => Alias column
464− -> By tables '(table, column)
465− By2
466− :: (HasTable table tables columns, HasColumn column columns ty)
467− => (Alias table, Alias column)
468− -> By tables '(table, column)
469−deriving instance Show (By tables by)
470−deriving instance Eq (By tables by)
471−deriving instance Ord (By tables by)
472−
473−renderBy :: By tables tabcolty -> ByteString
474−renderBy = \case
475− By column -> renderAlias column
476− By2 (table, column) -> renderAlias table <> "." <> renderAlias column
477−
478−data GroupByClause tables grouping where
479− NoGroups :: GroupByClause tables 'Ungrouped
480− Group
481− :: SListI bys
482− => NP (By tables) bys
483− -> GroupByClause tables ('Grouped bys)
484−
485−renderGroupByClause :: GroupByClause tables grouping -> ByteString
486−renderGroupByClause = \case
487− NoGroups -> ""
488− Group Nil -> ""
489− Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
490−
491−data HavingClause params tables grouping where
492− NoHaving :: HavingClause params tables 'Ungrouped
493− Having
494− :: [Condition params tables ('Grouped bys)]
495− -> HavingClause params tables ('Grouped bys)
496−deriving instance Show (HavingClause params tables grouping)
497−deriving instance Eq (HavingClause params tables grouping)
498−deriving instance Ord (HavingClause params tables grouping)
499−
500−renderHavingClause :: HavingClause params tables grouping -> ByteString
501−renderHavingClause = \case
502− NoHaving -> ""
503− Having [] -> ""
504− Having conditions ->
505− " HAVING" <+> commaSeparated (renderExpression <$> conditions)
506−
507−class (KnownSymbol table, KnownSymbol column)
508− => GroupedBy table column bys where
509− getGroup1
510− :: (tables ~ '[table ::: columns], HasColumn column columns ty)
511− => Alias column
512− -> Expression params tables ('Grouped bys) ty
513− getGroup1 column = UnsafeExpression $ renderAlias column
514− getGroup2
515− :: (HasTable table tables columns, HasColumn column columns ty)
516− => Alias table
517− -> Alias column
518− -> Expression params tables ('Grouped bys) ty
519− getGroup2 table column = UnsafeExpression $
520− renderAlias table <> "." <> renderAlias column
521−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
522− => GroupedBy table column ('(table,column) ': bys)
523−instance {-# OVERLAPPABLE #-}
524− ( KnownSymbol table
525− , KnownSymbol column
526− , GroupedBy table column bys
527− ) => GroupedBy table column (tabcol ': bys)
528−
529−instance
530− ( tables ~ '[table ::: columns]
531− , HasColumn column columns ty
532− , GroupedBy table column bys
533− ) => IsLabel column
534− (Expression params tables ('Grouped bys) ty) where
535− fromLabel = getGroup1 (Alias @column)
536−
537−instance
538− ( HasTable table tables columns
539− , HasColumn column columns ty
540− , GroupedBy table column bys
541− ) => IsTableColumn table column
542− (Expression params tables ('Grouped bys) ty) where (!) = getGroup2
543−
544−data AllOrDistinct = All | Distinct
545− deriving (GHC.Generic,Show,Eq,Ord,Data)
546−instance NFData AllOrDistinct
547−
548−renderAllOrDistinct :: AllOrDistinct -> ByteString
549−renderAllOrDistinct = \case
550− All -> "ALL"
551− Distinct -> "DISTINCT"
552−
553−unsafeAggregate
554− :: ByteString
555− -> AllOrDistinct
556− -> Expression params tables 'Ungrouped ('Required xty)
557− -> Expression params tables ('Grouped bys) ('Required yty)
558−unsafeAggregate fun allOrDistinct x = UnsafeExpression $ mconcat
559− [fun, "(", renderAllOrDistinct allOrDistinct <+> renderExpression x, ")"]
560−
561−sum_
562− :: PGNum ty
563− => AllOrDistinct
564− -> Expression params tables 'Ungrouped ('Required (nullity ty))
565− -> Expression params tables ('Grouped bys) ('Required (nullity ty))
566−sum_ = unsafeAggregate "sum"
567−
568−avgInt
569− :: PGIntegral int
570− => AllOrDistinct
571− -> Expression params tables 'Ungrouped ('Required (nullity int))
572− -> Expression params tables ('Grouped bys) ('Required (nullity 'PGnumeric))
573−avgInt = unsafeAggregate "avg"
574−
575−avgFloat
576− :: PGFloating float
577− => AllOrDistinct
578− -> Expression params tables 'Ungrouped ('Required (nullity float))
579− -> Expression params tables ('Grouped bys) ('Required (nullity 'PGfloat8))
580−avgFloat = unsafeAggregate "avg"
581−
582−bitAnd
583− :: PGIntegral int
584− => AllOrDistinct
585− -> Expression params tables 'Ungrouped ('Required (nullity int))
586− -> Expression params tables ('Grouped bys) ('Required (nullity int))
587−bitAnd = unsafeAggregate "bit_and"
588−
589−bitOr
590− :: PGIntegral int
591− => AllOrDistinct
592− -> Expression params tables 'Ungrouped ('Required (nullity int))
593− -> Expression params tables ('Grouped bys) ('Required (nullity int))
594−bitOr = unsafeAggregate "bit_or"
595−
596−boolAnd
597− :: AllOrDistinct
598− -> Expression params tables 'Ungrouped ('Required (nullity 'PGbool))
599− -> Expression params tables ('Grouped bys) ('Required (nullity 'PGbool))
600−boolAnd = unsafeAggregate "bool_and"
601−
602−boolOr
603− :: AllOrDistinct
604− -> Expression params tables 'Ungrouped ('Required (nullity 'PGbool))
605− -> Expression params tables ('Grouped bys) ('Required (nullity 'PGbool))
606−boolOr = unsafeAggregate "bool_or"
607−
608−countStar
609− :: AllOrDistinct
610− -> Expression params table ('Grouped bys) ('Required ('NotNull 'PGint8))
611−countStar allOrDistinct = UnsafeExpression $
612− "count(" <> renderAllOrDistinct allOrDistinct <+> "*)"
613−
614−count
615− :: AllOrDistinct
616− -> Expression params tables 'Ungrouped ('Required ty)
617− -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGint8))
618−count = unsafeAggregate "count"
619−
620−every
621− :: AllOrDistinct
622− -> Expression params tables 'Ungrouped ('Required (nullity 'PGbool))
623− -> Expression params tables ('Grouped bys) ('Required (nullity 'PGbool))
624−every = unsafeAggregate "every"
625−
626−jsonAgg
627− :: AllOrDistinct
628− -> Expression params tables 'Ungrouped ('Required ty)
629− -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjson))
630−jsonAgg = unsafeAggregate "json_agg"
631−
632−jsonbAgg
633− :: AllOrDistinct
634− -> Expression params tables 'Ungrouped ('Required ty)
635− -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjsonb))
636−jsonbAgg = unsafeAggregate "jsonb_agg"
637−
638−jsonObjectAgg
639− :: Expression params tables 'Ungrouped ('Required ('NotNull keyty))
640− -> Expression params tables 'Ungrouped ('Required valty)
641− -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjson))
642−jsonObjectAgg k v = UnsafeExpression $
643− "json_object_agg(" <> renderExpression k
644− <> ", " <> renderExpression v <> ")"
645−
646−jsonbObjectAgg
647− :: AllOrDistinct
648− -> Expression params tables 'Ungrouped ('Required ('NotNull keyty))
649− -> Expression params tables 'Ungrouped ('Required valty)
650− -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjsonb))
651−jsonbObjectAgg allOrDistinct k v = UnsafeExpression $
652− "jsonb_object_agg(" <> renderAllOrDistinct allOrDistinct
653− <+> renderExpression k <> ", " <> renderExpression v <> ")"
654−
655−max_
656− :: AllOrDistinct
657− -> Expression params tables 'Ungrouped ('Required (nullity ty))
658− -> Expression params tables ('Grouped bys) ('Required (nullity ty))
659−max_ = unsafeAggregate "max"
660−
661−min_
662− :: AllOrDistinct
663− -> Expression params tables 'Ungrouped ('Required (nullity ty))
664− -> Expression params tables ('Grouped bys) ('Required (nullity ty))
665−min_ = unsafeAggregate "min"
666−
667−{-----------------------------------------
668−tables
669−-----------------------------------------}
670−
671−newtype Table
672− (schema :: [(Symbol,[(Symbol,ColumnType)])])
673− (columns :: [(Symbol,ColumnType)])
674− = UnsafeTable { renderTable :: ByteString }
675− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
676−
677−class KnownSymbol table => HasTable table tables columns
678− | table tables -> columns where
679− getTable :: Alias table -> Table tables columns
680− getTable table = UnsafeTable $ renderAlias table
681−instance {-# OVERLAPPING #-} KnownSymbol table
682− => HasTable table ((table ::: columns) ': tables) columns
683−instance {-# OVERLAPPABLE #-}
684− (KnownSymbol table, HasTable table schema columns)
685− => HasTable table (table' ': schema) columns
686−
687−instance HasTable table schema columns
688− => IsLabel table (Table schema columns) where
689− fromLabel = getTable (Alias @table)
690−
691−data FromClause params schema tables where
692− Table
693− :: Aliased (Table schema) table
694− -> FromClause params schema '[table]
695− Subquery
696− :: Aliased (Query schema params) table
697− -> FromClause params schema '[table]
698− CrossJoin
699− :: FromClause params schema right
700− -> FromClause params schema left
701− -> FromClause params schema (Join left right)
702− InnerJoin
703− :: FromClause params schema right
704− -> Condition params (Join left right) 'Ungrouped
705− -> FromClause params schema left
706− -> FromClause params schema (Join left right)
707− LeftOuterJoin
708− :: FromClause params schema right
709− -> Condition params (Join left right) 'Ungrouped
710− -> FromClause params schema left
711− -> FromClause params schema (Join left (NullifyTables right))
712− RightOuterJoin
713− :: FromClause params schema right
714− -> Condition params (Join left right) 'Ungrouped
715− -> FromClause params schema left
716− -> FromClause params schema (Join (NullifyTables left) right)
717− FullOuterJoin
718− :: FromClause params schema right
719− -> Condition params (Join left right) 'Ungrouped
720− -> FromClause params schema left
721− -> FromClause params schema
722− (Join (NullifyTables left) (NullifyTables right))
723−
724−renderFromClause :: FromClause params schema tables -> ByteString
725−renderFromClause = \case
726− Table table -> renderAliased renderTable table
727− Subquery selection -> renderAliased (parenthesized . renderQuery) selection
728− CrossJoin right left ->
729− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
730− InnerJoin right on left -> renderJoin "INNER JOIN" right on left
731− LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left
732− RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left
733− FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left
734− where
735− renderJoin op right on left =
736− renderFromClause left <+> op <+> renderFromClause right
737− <+> "ON" <+> renderExpression on
738−
739−data TableExpression
740− (params :: [ColumnType])
741− (schema :: [(Symbol,[(Symbol,ColumnType)])])
742− (tables :: [(Symbol,[(Symbol,ColumnType)])])
743− (grouping :: Grouping)
744− = TableExpression
745− { fromClause :: FromClause params schema tables
746− , whereClause :: [Condition params tables 'Ungrouped]
747− , groupByClause :: GroupByClause tables grouping
748− , havingClause :: HavingClause params tables grouping
749− , orderByClause :: [SortExpression params tables grouping]
750− , limitClause :: [Word64]
751− , offsetClause :: [Word64]
752− }
753−
754−renderTableExpression
755− :: TableExpression params schema tables grouping
756− -> ByteString
757−renderTableExpression
758− (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat
759− [ "FROM ", renderFromClause tables
760− , renderWheres whs'
761− , renderGroupByClause grps'
762− , renderHavingClause hvs'
763− , renderSorts srts'
764− , renderLimits lims'
765− , renderOffsets offs'
766− ]
767− where
768− renderWheres = \case
769− [] -> ""
770− wh:[] -> " WHERE" <+> renderExpression wh
771− wh:whs -> " WHERE" <+> renderExpression (foldr (&&*) wh whs)
772− renderSorts = \case
773− [] -> ""
774− srts -> " SORT BY"
775− <+> commaSeparated (renderSortExpression <$> srts)
776− renderLimits = \case
777− [] -> ""
778− lims -> " LIMIT" <+> fromString (show (minimum lims))
779− renderOffsets = \case
780− [] -> ""
781− offs -> " OFFSET" <+> fromString (show (sum offs))
782−
783−from
784− :: FromClause params schema tables
785− -> TableExpression params schema tables 'Ungrouped
786−from tables = TableExpression tables [] NoGroups NoHaving [] [] []
787−
788−where_
789− :: Condition params tables 'Ungrouped
790− -> TableExpression params schema tables grouping
791− -> TableExpression params schema tables grouping
792−where_ wh tables = tables {whereClause = wh : whereClause tables}
793−
794−group
795− :: SListI bys
796− => NP (By tables) bys
797− -> TableExpression params schema tables 'Ungrouped
798− -> TableExpression params schema tables ('Grouped bys)
799−group bys tables = TableExpression
800− { fromClause = fromClause tables
801− , whereClause = whereClause tables
802− , groupByClause = Group bys
803− , havingClause = Having []
804− , orderByClause = []
805− , limitClause = limitClause tables
806− , offsetClause = offsetClause tables
807− }
808−
809−having
810− :: Condition params tables ('Grouped bys)
811− -> TableExpression params schema tables ('Grouped bys)
812− -> TableExpression params schema tables ('Grouped bys)
813−having hv tables = tables
814− { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }
815−
816−orderBy
817− :: [SortExpression params tables grouping]
818− -> TableExpression params schema tables grouping
819− -> TableExpression params schema tables grouping
820−orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}
821−
822−limit
823− :: Word64
824− -> TableExpression params schema tables grouping
825− -> TableExpression params schema tables grouping
826−limit lim tables = tables {limitClause = lim : limitClause tables}
827−
828−offset
829− :: Word64
830− -> TableExpression params schema tables grouping
831− -> TableExpression params schema tables grouping
832−offset off tables = tables {offsetClause = off : offsetClause tables}
833−
834−{-----------------------------------------
835−type expressions
836−-----------------------------------------}
837−
838−newtype TypeExpression (ty :: ColumnType)
839− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
840− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
841−
842−bool :: TypeExpression ('Required ('Null 'PGbool))
843−bool = UnsafeTypeExpression "bool"
844−int2 :: TypeExpression ('Required ('Null 'PGint2))
845−int2 = UnsafeTypeExpression "int2"
846−smallint :: TypeExpression ('Required ('Null 'PGint2))
847−smallint = UnsafeTypeExpression "smallint"
848−int4 :: TypeExpression ('Required ('Null 'PGint4))
849−int4 = UnsafeTypeExpression "int4"
850−int :: TypeExpression ('Required ('Null 'PGint4))
851−int = UnsafeTypeExpression "int"
852−integer :: TypeExpression ('Required ('Null 'PGint4))
853−integer = UnsafeTypeExpression "integer"
854−int8 :: TypeExpression ('Required ('Null 'PGint8))
855−int8 = UnsafeTypeExpression "int8"
856−bigint :: TypeExpression ('Required ('Null 'PGint8))
857−bigint = UnsafeTypeExpression "bigint"
858−numeric :: TypeExpression ('Required ('Null 'PGnumeric))
859−numeric = UnsafeTypeExpression "numeric"
860−float4 :: TypeExpression ('Required ('Null 'PGfloat4))
861−float4 = UnsafeTypeExpression "float4"
862−real :: TypeExpression ('Required ('Null 'PGfloat4))
863−real = UnsafeTypeExpression "real"
864−float8 :: TypeExpression ('Required ('Null 'PGfloat8))
865−float8 = UnsafeTypeExpression "float8"
866−doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))
867−doublePrecision = UnsafeTypeExpression "double precision"
868−serial2 :: TypeExpression ('Optional ('NotNull 'PGint2))
869−serial2 = UnsafeTypeExpression "serial2"
870−smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))
871−smallserial = UnsafeTypeExpression "smallserial"
872−serial4 :: TypeExpression ('Optional ('NotNull 'PGint4))
873−serial4 = UnsafeTypeExpression "serial4"
874−serial :: TypeExpression ('Optional ('NotNull 'PGint4))
875−serial = UnsafeTypeExpression "serial"
876−serial8 :: TypeExpression ('Optional ('NotNull 'PGint8))
877−serial8 = UnsafeTypeExpression "serial8"
878−bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))
879−bigserial = UnsafeTypeExpression "bigserial"
880−text :: TypeExpression ('Required ('Null 'PGtext))
881−text = UnsafeTypeExpression "text"
882−char
883− :: KnownNat n
884− => proxy n
885− -> TypeExpression ('Required ('Null ('PGchar n)))
886−char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
887−character
888− :: KnownNat n
889− => proxy n
890− -> TypeExpression ('Required ('Null ('PGchar n)))
891−character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
892−varchar
893− :: KnownNat n
894− => proxy n
895− -> TypeExpression ('Required ('Null ('PGvarchar n)))
896−varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
897−characterVarying
898− :: KnownNat n
899− => proxy n
900− -> TypeExpression ('Required ('Null ('PGvarchar n)))
901−characterVarying p = UnsafeTypeExpression $
902− "character varying(" <> renderNat p <> ")"
903−bytea :: TypeExpression ('Required ('Null ('PGbytea)))
904−bytea = UnsafeTypeExpression "bytea"
905−timestamp :: TypeExpression ('Required ('Null ('PGtimestamp)))
906−timestamp = UnsafeTypeExpression "timestamp"
907−timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGtimestamptz)))
908−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
909−date :: TypeExpression ('Required ('Null ('PGdate)))
910−date = UnsafeTypeExpression "date"
911−time :: TypeExpression ('Required ('Null ('PGtime)))
912−time = UnsafeTypeExpression "time"
913−timeWithTimeZone :: TypeExpression ('Required ('Null ('PGtimetz)))
914−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
915−interval :: TypeExpression ('Required ('Null ('PGinterval)))
916−interval = UnsafeTypeExpression "interval"
917−uuid :: TypeExpression ('Required ('Null ('PGuuid)))
918−uuid = UnsafeTypeExpression "uuid"
919−json :: TypeExpression ('Required ('Null ('PGjson)))
920−json = UnsafeTypeExpression "json"
921−jsonb :: TypeExpression ('Required ('Null ('PGjsonb)))
922−jsonb = UnsafeTypeExpression "jsonb"
923−
924−notNull
925− :: TypeExpression (optionality ('Null ty))
926− -> TypeExpression (optionality ('NotNull ty))
927−notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
928−default_
929− :: Expression '[] '[] 'Ungrouped ('Required ty)
930− -> TypeExpression ('Required ty)
931− -> TypeExpression ('Optional ty)
932−default_ x ty = UnsafeTypeExpression $
933− renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x
934−
935−class PGTyped (ty :: PGType) where
936− pgtype :: TypeExpression ('Required ('Null ty))
937−instance PGTyped 'PGbool where pgtype = bool
938−instance PGTyped 'PGint2 where pgtype = int2
939−instance PGTyped 'PGint4 where pgtype = int4
940−instance PGTyped 'PGint8 where pgtype = int8
941−instance PGTyped 'PGnumeric where pgtype = numeric
942−instance PGTyped 'PGfloat4 where pgtype = float4
943−instance PGTyped 'PGfloat8 where pgtype = float8
944−instance PGTyped 'PGtext where pgtype = text
945−instance KnownNat n => PGTyped ('PGchar n) where pgtype = char (Proxy @n)
946−instance KnownNat n => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)
947−instance PGTyped 'PGbytea where pgtype = bytea
948−instance PGTyped 'PGtimestamp where pgtype = timestamp
949−instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone
950−instance PGTyped 'PGdate where pgtype = date
951−instance PGTyped 'PGtime where pgtype = time
952−instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone
953−instance PGTyped 'PGinterval where pgtype = interval
954−instance PGTyped 'PGuuid where pgtype = uuid
955−instance PGTyped 'PGjson where pgtype = json
956−instance PGTyped 'PGjsonb where pgtype = jsonb
957−
958−{-----------------------------------------
959−statements
960−-----------------------------------------}
961−
962−newtype Definition
963− (schema0 :: [(Symbol,[(Symbol,ColumnType)])])
964− (schema1 :: [(Symbol,[(Symbol,ColumnType)])])
965− = UnsafeDefinition { renderDefinition :: ByteString }
966− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
967−
968−instance Category Definition where
969− id = UnsafeDefinition ";"
970− ddl1 . ddl0 = UnsafeDefinition $
971− renderDefinition ddl0 <+> renderDefinition ddl1
972−
973−newtype Manipulation
974− (schema :: [(Symbol,[(Symbol,ColumnType)])])
975− (params :: [ColumnType])
976− (columns :: [(Symbol,ColumnType)])
977− = UnsafeManipulation { renderManipulation :: ByteString }
978− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
979−
980−newtype Query
981− (schema :: [(Symbol,[(Symbol,ColumnType)])])
982− (params :: [ColumnType])
983− (columns :: [(Symbol,ColumnType)])
984− = UnsafeQuery { renderQuery :: ByteString }
985− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
986−
987−queryStatement
988− :: Query schema params columns
989− -> Manipulation schema params columns
990−queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
991−
992−union, unionAll, intersect, intersectAll, except, exceptAll
993− :: Query schema params columns
994− -> Query schema params columns
995− -> Query schema params columns
996−q1 `union` q2 = UnsafeQuery $
997− parenthesized (renderQuery q1)
998− <+> "UNION"
999− <+> parenthesized (renderQuery q2)
1000−q1 `unionAll` q2 = UnsafeQuery $
1001− parenthesized (renderQuery q1)
1002− <+> "UNION" <+> "ALL"
1003− <+> parenthesized (renderQuery q2)
1004−q1 `intersect` q2 = UnsafeQuery $
1005− parenthesized (renderQuery q1)
1006− <+> "INTERSECT"
1007− <+> parenthesized (renderQuery q2)
1008−q1 `intersectAll` q2 = UnsafeQuery $
1009− parenthesized (renderQuery q1)
1010− <+> "INTERSECT" <+> "ALL"
1011− <+> parenthesized (renderQuery q2)
1012−q1 `except` q2 = UnsafeQuery $
1013− parenthesized (renderQuery q1)
1014− <+> "EXCEPT"
1015− <+> parenthesized (renderQuery q2)
1016−q1 `exceptAll` q2 = UnsafeQuery $
1017− parenthesized (renderQuery q1)
1018− <+> "EXCEPT" <+> "ALL"
1019− <+> parenthesized (renderQuery q2)
1020−
1021−{-----------------------------------------
1022−SELECT statements
1023−-----------------------------------------}
1024−
1025−select
1026− :: SListI columns
1027− => NP (Aliased (Expression params tables grouping)) (column ': columns)
1028− -> TableExpression params schema tables grouping
1029− -> Query schema params (column ': columns)
1030−select list tabs = UnsafeQuery $
1031− "SELECT"
1032− <+> renderCommaSeparated (renderAliased renderExpression) list
1033− <+> renderTableExpression tabs
1034−
1035−selectDistinct
1036− :: SListI columns
1037− => NP (Aliased (Expression params tables grouping)) (column ': columns)
1038− -> TableExpression params schema tables grouping
1039− -> Query schema params (column ': columns)
1040−selectDistinct list tabs = UnsafeQuery $
1041− "SELECT DISTINCT"
1042− <+> renderCommaSeparated (renderAliased renderExpression) list
1043− <+> renderTableExpression tabs
1044−
1045−selectStar
1046− :: tables ~ '[table ::: columns]
1047− => TableExpression params schema tables 'Ungrouped
1048− -> Query schema params columns
1049−selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs
1050−
1051−selectDistinctStar
1052− :: tables ~ '[table ::: columns]
1053− => TableExpression params schema tables 'Ungrouped
1054− -> Query schema params columns
1055−selectDistinctStar tabs = UnsafeQuery $
1056− "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs
1057−
1058−selectDotStar
1059− :: HasTable table tables columns
1060− => Alias table
1061− -> TableExpression params schema tables 'Ungrouped
1062− -> Query schema params columns
1063−selectDotStar table tables = UnsafeQuery $
1064− "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables
1065−
1066−selectDistinctDotStar
1067− :: HasTable table tables columns
1068− => Alias table
1069− -> TableExpression params schema tables 'Ungrouped
1070− -> Query schema params columns
1071−selectDistinctDotStar table tables = UnsafeQuery $
1072− "SELECT DISTINCT" <+> renderAlias table <> ".*"
1073− <+> renderTableExpression tables
1074−
1075−{-----------------------------------------
1076−CREATE statements
1077−-----------------------------------------}
1078−
1079−createTable
1080− :: (KnownSymbol table, SListI columns)
1081− => Alias table
1082− -> NP (Aliased TypeExpression) (column ': columns)
1083− -> [TableConstraint schema (column ': columns)]
1084− -> Definition schema (Create table (column ': columns) schema)
1085−createTable table columns constraints = UnsafeDefinition $
1086− "CREATE TABLE" <+> renderAlias table
1087− <+> parenthesized
1088− ( renderCommaSeparated renderColumnDef columns
1089− <> renderConstraints constraints )
1090− <> ";"
1091− where
1092− renderColumnDef :: Aliased TypeExpression x -> ByteString
1093− renderColumnDef (ty `As` column) =
1094− renderAlias column <+> renderTypeExpression ty
1095− renderConstraints :: [TableConstraint schema columns] -> ByteString
1096− renderConstraints = \case
1097− [] -> ""
1098− _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
1099−
1100−newtype TableConstraint
1101− (schema :: [(Symbol,[(Symbol,ColumnType)])])
1102− (columns :: [(Symbol,ColumnType)])
1103− = UnsafeTableConstraint { renderTableConstraint :: ByteString }
1104− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1105−
1106−check
1107− :: Condition '[] '[table ::: columns] 'Ungrouped
1108− -> TableConstraint schema columns
1109−check condition = UnsafeTableConstraint $
1110− "CHECK" <+> parenthesized (renderExpression condition)
1111−
1112−renderColumn :: Column columns columnty -> ByteString
1113−renderColumn (Column column) = renderAlias column
1114−
1115−unique
1116− :: SListI subcolumns
1117− => NP (Column columns) subcolumns
1118− -> TableConstraint schema columns
1119−unique columns = UnsafeTableConstraint $
1120− "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
1121−
1122−primaryKey
1123− :: (SListI subcolumns, AllNotNull subcolumns)
1124− => NP (Column columns) subcolumns
1125− -> TableConstraint schema columns
1126−primaryKey columns = UnsafeTableConstraint $
1127− "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
1128−
1129−foreignKey
1130− :: ( HasTable reftable schema refcolumns
1131− , SameTypes subcolumns refsubcolumns
1132− , NotAllNull subcolumns
1133− , SListI subcolumns
1134− , SListI refsubcolumns)
1135− => NP (Column columns) subcolumns
1136− -> Alias reftable
1137− -> NP (Column refcolumns) refsubcolumns
1138− -> OnDelete
1139− -> OnUpdate
1140− -> TableConstraint schema columns
1141−foreignKey columns reftable refcolumns onDelete onUpdate =
1142− UnsafeTableConstraint $
1143− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
1144− <+> "REFERENCES" <+> renderAlias reftable
1145− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
1146− <+> renderOnDelete onDelete
1147− <+> renderOnUpdate onUpdate
1148−
1149−data OnDelete
1150− = OnDeleteNoAction
1151− | OnDeleteRestrict
1152− | OnDeleteCascade
1153− deriving (GHC.Generic,Show,Eq,Ord,Data)
1154−instance NFData OnDelete
1155−
1156−renderOnDelete :: OnDelete -> ByteString
1157−renderOnDelete = \case
1158− OnDeleteNoAction -> "ON DELETE NO ACTION"
1159− OnDeleteRestrict -> "ON DELETE RESTRICT"
1160− OnDeleteCascade -> "ON DELETE CASCADE"
1161−
1162−data OnUpdate
1163− = OnUpdateNoAction
1164− | OnUpdateRestrict
1165− | OnUpdateCascade
1166− deriving (GHC.Generic,Show,Eq,Ord,Data)
1167−instance NFData OnUpdate
1168−
1169−renderOnUpdate :: OnUpdate -> ByteString
1170−renderOnUpdate = \case
1171− OnUpdateNoAction -> "ON UPDATE NO ACTION"
1172− OnUpdateRestrict -> "ON UPDATE RESTRICT"
1173− OnUpdateCascade -> "ON UPDATE CASCADE"
1174−
1175−{-----------------------------------------
1176−DROP statements
1177−-----------------------------------------}
1178−
1179−dropTable
1180− :: KnownSymbol table
1181− => Alias table
1182− -> Definition schema (Drop table schema)
1183−dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
1184−
1185−{-----------------------------------------
1186−ALTER statements
1187−-----------------------------------------}
1188−
1189−alterTable
1190− :: HasTable table schema columns0
1191− => Alias table
1192− -> AlterTable columns0 columns1
1193− -> Definition schema (Alter table schema columns1)
1194−alterTable table alteration = UnsafeDefinition $
1195− "ALTER TABLE"
1196− <+> renderAlias table
1197− <+> renderAlterTable alteration
1198− <> ";"
1199−
1200−alterTableRename
1201− :: (KnownSymbol table0, KnownSymbol table1)
1202− => Alias table0
1203− -> Alias table1
1204− -> Definition schema (Rename table0 table1 schema)
1205−alterTableRename table0 table1 = UnsafeDefinition $
1206− "ALTER TABLE" <+> renderAlias table0
1207− <+> "RENAME TO" <+> renderAlias table1 <> ";"
1208−
1209−newtype AlterTable
1210− (columns0 :: [(Symbol, ColumnType)])
1211− (columns1 :: [(Symbol, ColumnType)]) =
1212− UnsafeAlterTable {renderAlterTable :: ByteString}
1213− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1214−
1215−addColumnDefault
1216− :: KnownSymbol column
1217− => Alias column
1218− -> TypeExpression ('Optional ty)
1219− -> AlterTable columns (Create column ('Optional ty) columns)
1220−addColumnDefault column ty = UnsafeAlterTable $
1221− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
1222−
1223−addColumnNull
1224− :: KnownSymbol column
1225− => Alias column
1226− -> TypeExpression ('Required ('Null ty))
1227− -> AlterTable columns ((column ::: 'Required ('Null ty)) ': columns)
1228−addColumnNull column ty = UnsafeAlterTable $
1229− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
1230−
1231−dropColumn
1232− :: KnownSymbol column
1233− => Alias column
1234− -> AlterTable columns (Drop column columns)
1235−dropColumn column = UnsafeAlterTable $
1236− "DROP COLUMN" <+> renderAlias column
1237−
1238−renameColumn
1239− :: (KnownSymbol column0, KnownSymbol column1)
1240− => Alias column0
1241− -> Alias column1
1242− -> AlterTable columns (Rename column0 column1 columns)
1243−renameColumn column0 column1 = UnsafeAlterTable $
1244− "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
1245−
1246−alterColumn
1247− :: (KnownSymbol column, HasColumn column columns ty0)
1248− => Alias column
1249− -> AlterColumn ty0 ty1
1250− -> AlterTable columns (Alter column columns ty1)
1251−alterColumn column alteration = UnsafeAlterTable $
1252− "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
1253−
1254−newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
1255− UnsafeAlterColumn {renderAlterColumn :: ByteString}
1256− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1257−
1258−setDefault
1259− :: Expression '[] '[] 'Ungrouped ('Required ty)
1260− -> AlterColumn ('Required ty) ('Optional ty)
1261−setDefault expression = UnsafeAlterColumn $
1262− "SET DEFAULT" <+> renderExpression expression
1263−
1264−dropDefault :: AlterColumn ('Optional ty) ('Required ty)
1265−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
1266−
1267−setNotNull
1268− :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))
1269−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
1270−
1271−dropNotNull
1272− :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))
1273−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
1274−
1275−alterType
1276− :: TypeExpression (optionality (nullity ty1))
1277− -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))
1278−alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty
1279−
1280−{-----------------------------------------
1281−INSERT statements
1282−-----------------------------------------}
1283−
1284−insertInto
1285− :: (SListI columns, SListI results, HasTable table schema columns)
1286− => Alias table
1287− -> ValuesClause schema params columns
1288− -> ConflictClause params columns
1289− -> ReturningClause params columns results
1290− -> Manipulation schema params results
1291−insertInto table insert conflict returning = UnsafeManipulation $
1292− "INSERT" <+> "INTO" <+> renderAlias table
1293− <+> renderValuesClause insert
1294− <> renderConflictClause conflict
1295− <> renderReturningClause returning
1296−
1297−data ValuesClause
1298− (schema :: [(Symbol,[(Symbol,ColumnType)])])
1299− (params :: [ColumnType])
1300− (columns :: [(Symbol,ColumnType)])
1301− = Values
1302− (NP (Aliased (Expression params '[] 'Ungrouped)) columns)
1303− [NP (Aliased (Expression params '[] 'Ungrouped)) columns]
1304− | ValuesQuery (Query schema params columns)
1305−
1306−renderValuesClause
1307− :: SListI columns
1308− => ValuesClause schema params columns
1309− -> ByteString
1310−renderValuesClause = \case
1311− Values row rows ->
1312− parenthesized (renderCommaSeparated renderAliasPart row)
1313− <+> "VALUES"
1314− <+> commaSeparated
1315− (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)
1316− where
1317− renderAliasPart, renderValuePart
1318− :: Aliased (Expression params '[] 'Ungrouped) ty -> ByteString
1319− renderAliasPart (_ `As` name) = renderAlias name
1320− renderValuePart (value `As` _) = renderExpression value
1321− ValuesQuery q -> renderQuery q
1322−
1323−data ReturningClause
1324− (params :: [ColumnType])
1325− (columns :: [(Symbol,ColumnType)])
1326− (results :: [(Symbol,ColumnType)])
1327− where
1328− ReturningStar :: ReturningClause params columns columns
1329− Returning
1330− :: NP
1331− (Aliased (Expression params '[table ::: columns] 'Ungrouped))
1332− results
1333− -> ReturningClause params columns results
1334−
1335−renderReturningClause
1336− :: SListI results
1337− => ReturningClause params columns results
1338− -> ByteString
1339−renderReturningClause = \case
1340− ReturningStar -> " RETURNING *;"
1341− Returning Nil -> ";"
1342− Returning results -> " RETURNING"
1343− <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"
1344−
1345−data ConflictClause params columns where
1346− Conflict :: ConflictClause params columns
1347− OnConflictDoNothing :: ConflictClause params columns
1348− OnConflictDoUpdate
1349− :: NP (Aliased (UpdateExpression params columns)) columns
1350− -> Maybe (Condition params '[table ::: columns] 'Ungrouped)
1351− -> ConflictClause params columns
1352−
1353−renderConflictClause
1354− :: SListI columns
1355− => ConflictClause params columns
1356− -> ByteString
1357−renderConflictClause = \case
1358− Conflict -> ""
1359− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
1360− OnConflictDoUpdate updates whMaybe
1361− -> " ON CONFLICT DO UPDATE SET"
1362− <+> renderCommaSeparatedMaybe renderUpdateExpression updates
1363− <> case whMaybe of
1364− Nothing -> ""
1365− Just wh -> " WHERE" <+> renderExpression wh
1366−
1367−{-----------------------------------------
1368−UPDATE statements
1369−-----------------------------------------}
1370−
1371−data UpdateExpression params columns ty
1372− = Same
1373− | Set (forall table. Expression params '[table ::: columns] 'Ungrouped ty)
1374−deriving instance Show (UpdateExpression params columns ty)
1375−deriving instance Eq (UpdateExpression params columns ty)
1376−deriving instance Ord (UpdateExpression params columns ty)
1377−
1378−renderUpdateExpression
1379− :: Aliased (UpdateExpression params columns) column
1380− -> Maybe ByteString
1381−renderUpdateExpression = \case
1382− Same `As` _ -> Nothing
1383− Set expression `As` column -> Just $
1384− renderAlias column <+> "=" <+> renderExpression expression
1385−
1386−update
1387− :: (HasTable table schema columns, SListI columns, SListI results)
1388− => Alias table
1389− -> NP (Aliased (UpdateExpression params columns)) columns
1390− -> Condition params '[tab ::: columns] 'Ungrouped
1391− -> ReturningClause params columns results
1392− -> Manipulation schema params results
1393−update table columns wh returning = UnsafeManipulation $
1394− "UPDATE"
1395− <+> renderAlias table
1396− <+> "SET"
1397− <+> renderCommaSeparatedMaybe renderUpdateExpression columns
1398− <+> "WHERE" <+> renderExpression wh
1399− <> renderReturningClause returning
1400−
1401−{-----------------------------------------
1402−DELETE statements
1403−-----------------------------------------}
1404−
1405−deleteFrom
1406− :: HasTable table schema columns
1407− => Alias table
1408− -> Condition params '[table ::: columns] 'Ungrouped
1409− -> Manipulation schema params '[]
1410−deleteFrom table wh = UnsafeManipulation $
1411− "DELETE FROM" <+> renderAlias table
1412− <+> "WHERE" <+> renderExpression wh <> ";"
1413−
1414−{-----------------------------------------
1415−render helper functions
1416−-----------------------------------------}
1417−
1418−parenthesized :: ByteString -> ByteString
1419−parenthesized str = "(" <> str <> ")"
1420−
1421−(<+>) :: ByteString -> ByteString -> ByteString
1422−str1 <+> str2 = str1 <> " " <> str2
1423−
1424−commaSeparated :: [ByteString] -> ByteString
1425−commaSeparated = ByteString.intercalate ", "
1426−
1427−renderCommaSeparated
1428− :: SListI xs
1429− => (forall x. expression x -> ByteString)
1430− -> NP expression xs -> ByteString
1431−renderCommaSeparated render
1432− = commaSeparated
1433− . hcollapse
1434− . hmap (K . render)
1435−
1436−renderCommaSeparatedMaybe
1437− :: SListI xs
1438− => (forall x. expression x -> Maybe ByteString)
1439− -> NP expression xs -> ByteString
1440−renderCommaSeparatedMaybe render
1441− = commaSeparated
1442− . catMaybes
1443− . hcollapse
1444− . hmap (K . render)
1445−
1446−renderNat :: KnownNat n => proxy n -> ByteString
1447−renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))