git.iko.soy/squeal
on dev help sign in
modularize
ef156edEitan Chatav
squeal-postgresql/squeal-postgresql.cabal+8−2
compare with dev
unifiedsplit
@@ -15,8 +15,12 @@ library
15 exposed-modules:
15 exposed-modules:
16 Squeal.PostgreSQL
16 Squeal.PostgreSQL
17 Squeal.PostgreSQL.Binary
17 Squeal.PostgreSQL.Binary
18+ Squeal.PostgreSQL.Definition
19+ Squeal.PostgreSQL.Expression
20+ Squeal.PostgreSQL.Manipulation
18 Squeal.PostgreSQL.PQ
21 Squeal.PostgreSQL.PQ
19− Squeal.PostgreSQL.Statement
22+ Squeal.PostgreSQL.Prettyprint
23+ Squeal.PostgreSQL.Query
20 Squeal.PostgreSQL.Schema
24 Squeal.PostgreSQL.Schema
21 default-language: Haskell2010
25 default-language: Haskell2010
22 ghc-options: -Wall -Werror -fprint-explicit-kinds
26 ghc-options: -Wall -Werror -fprint-explicit-kinds
@@ -46,7 +50,9 @@ test-suite squeal-postgresql-test
46 ghc-options: -Wall -Werror
50 ghc-options: -Wall -Werror
47 main-is: Spec.hs
51 main-is: Spec.hs
48 other-modules:
52 other-modules:
49− Squeal.PostgreSQL.StatementSpec
53+ Squeal.PostgreSQL.DefinitionSpec
54+ Squeal.PostgreSQL.ManipulationSpec
55+ Squeal.PostgreSQL.QuerySpec
50 build-depends:
56 build-depends:
51 base
57 base
52 , generics-sop
58 , generics-sop
squeal-postgresql/src/Squeal/PostgreSQL.hs+8−2
@@ -1,11 +1,17 @@
1module Squeal.PostgreSQL
1module Squeal.PostgreSQL
2 ( module Squeal.PostgreSQL.Binary
2 ( module Squeal.PostgreSQL.Binary
3+ , module Squeal.PostgreSQL.Definition
4+ , module Squeal.PostgreSQL.Expression
5+ , module Squeal.PostgreSQL.Manipulation
3 , module Squeal.PostgreSQL.PQ
6 , module Squeal.PostgreSQL.PQ
7+ , module Squeal.PostgreSQL.Query
4 , module Squeal.PostgreSQL.Schema
8 , module Squeal.PostgreSQL.Schema
5− , module Squeal.PostgreSQL.Statement
6 ) where
9 ) where
7
10
8import Squeal.PostgreSQL.Binary
11import Squeal.PostgreSQL.Binary
12+import Squeal.PostgreSQL.Definition
13+import Squeal.PostgreSQL.Expression
14+import Squeal.PostgreSQL.Manipulation
9import Squeal.PostgreSQL.PQ
15import Squeal.PostgreSQL.PQ
16+import Squeal.PostgreSQL.Query
10import Squeal.PostgreSQL.Schema
17import Squeal.PostgreSQL.Schema
11−import Squeal.PostgreSQL.Statement
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+2−1
@@ -67,7 +67,8 @@ import Squeal.PostgreSQL.Schema
67-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
67-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
68-- into the binary format of a PostgreSQL `PGType`.
68-- into the binary format of a PostgreSQL `PGType`.
69class ToParam (x :: Type) (pg :: PGType) where
69class ToParam (x :: Type) (pg :: PGType) where
70+ -- | >>> :set -XTypeApplications -XDataKinds
70− -- | >>> toParam @Bool @'PGbool False
71+ -- >>> toParam @Bool @'PGbool False
71 -- K "\NUL"
72 -- K "\NUL"
72 --
73 --
73 -- >>> toParam @Int16 @'PGint2 0
74 -- >>> toParam @Int16 @'PGint2 0
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hsnew file+276
@@ -0,0 +1,276 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveDataTypeable
4+ , DeriveGeneric
5+ , GADTs
6+ , GeneralizedNewtypeDeriving
7+ , KindSignatures
8+ , LambdaCase
9+ , OverloadedStrings
10+ , RankNTypes
11+ , StandaloneDeriving
12+ , TypeInType
13+ , TypeOperators
14+#-}
15+
16+module Squeal.PostgreSQL.Definition
17+ ( -- * Data Definition Language
18+ Definition (UnsafeDefinition, renderDefinition)
19+ , createTable
20+ , TableConstraint (UnsafeTableConstraint, renderTableConstraint)
21+ , check
22+ , unique
23+ , primaryKey
24+ , foreignKey
25+ , OnDelete (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
26+ , renderOnDelete
27+ , OnUpdate (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
28+ , renderOnUpdate
29+ , dropTable
30+ , alterTable
31+ , alterTableRename
32+ , AlterTable (UnsafeAlterTable, renderAlterTable)
33+ , addColumnDefault
34+ , addColumnNull
35+ , dropColumn
36+ , renameColumn
37+ , alterColumn
38+ , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
39+ , setDefault
40+ , dropDefault
41+ , setNotNull
42+ , dropNotNull
43+ , alterType
44+ ) where
45+
46+import Control.Category
47+import Control.DeepSeq
48+import Data.ByteString
49+import Data.Data
50+import Data.Monoid
51+import Generics.SOP
52+import GHC.TypeLits
53+import Prelude hiding ((.), id)
54+
55+import qualified GHC.Generics as GHC
56+
57+import Squeal.PostgreSQL.Expression
58+import Squeal.PostgreSQL.Prettyprint
59+import Squeal.PostgreSQL.Schema
60+
61+{-----------------------------------------
62+statements
63+-----------------------------------------}
64+
65+newtype Definition
66+ (schema0 :: TablesType)
67+ (schema1 :: TablesType)
68+ = UnsafeDefinition { renderDefinition :: ByteString }
69+ deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
70+
71+instance Category Definition where
72+ id = UnsafeDefinition ";"
73+ ddl1 . ddl0 = UnsafeDefinition $
74+ renderDefinition ddl0 <+> renderDefinition ddl1
75+
76+{-----------------------------------------
77+CREATE statements
78+-----------------------------------------}
79+
80+createTable
81+ :: (KnownSymbol table, SListI columns)
82+ => Alias table
83+ -> NP (Aliased TypeExpression) (column ': columns)
84+ -> [TableConstraint schema (column ': columns)]
85+ -> Definition schema (Create table (column ': columns) schema)
86+createTable table columns constraints = UnsafeDefinition $
87+ "CREATE TABLE" <+> renderAlias table
88+ <+> parenthesized
89+ ( renderCommaSeparated renderColumnDef columns
90+ <> renderConstraints constraints )
91+ <> ";"
92+ where
93+ renderColumnDef :: Aliased TypeExpression x -> ByteString
94+ renderColumnDef (ty `As` column) =
95+ renderAlias column <+> renderTypeExpression ty
96+ renderConstraints :: [TableConstraint schema columns] -> ByteString
97+ renderConstraints = \case
98+ [] -> ""
99+ _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
100+
101+newtype TableConstraint
102+ (schema :: TablesType)
103+ (columns :: ColumnsType)
104+ = UnsafeTableConstraint { renderTableConstraint :: ByteString }
105+ deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
106+
107+check
108+ :: Condition '[] '[table ::: columns] 'Ungrouped
109+ -> TableConstraint schema columns
110+check condition = UnsafeTableConstraint $
111+ "CHECK" <+> parenthesized (renderExpression condition)
112+
113+unique
114+ :: SListI subcolumns
115+ => NP (Column columns) subcolumns
116+ -> TableConstraint schema columns
117+unique columns = UnsafeTableConstraint $
118+ "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
119+
120+primaryKey
121+ :: (SListI subcolumns, AllNotNull subcolumns)
122+ => NP (Column columns) subcolumns
123+ -> TableConstraint schema columns
124+primaryKey columns = UnsafeTableConstraint $
125+ "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
126+
127+foreignKey
128+ :: ( HasTable reftable schema refcolumns
129+ , SameTypes subcolumns refsubcolumns
130+ , NotAllNull subcolumns
131+ , SListI subcolumns
132+ , SListI refsubcolumns)
133+ => NP (Column columns) subcolumns
134+ -> Alias reftable
135+ -> NP (Column refcolumns) refsubcolumns
136+ -> OnDelete
137+ -> OnUpdate
138+ -> TableConstraint schema columns
139+foreignKey columns reftable refcolumns onDelete onUpdate =
140+ UnsafeTableConstraint $
141+ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
142+ <+> "REFERENCES" <+> renderAlias reftable
143+ <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
144+ <+> renderOnDelete onDelete
145+ <+> renderOnUpdate onUpdate
146+
147+data OnDelete
148+ = OnDeleteNoAction
149+ | OnDeleteRestrict
150+ | OnDeleteCascade
151+ deriving (GHC.Generic,Show,Eq,Ord,Data)
152+instance NFData OnDelete
153+
154+renderOnDelete :: OnDelete -> ByteString
155+renderOnDelete = \case
156+ OnDeleteNoAction -> "ON DELETE NO ACTION"
157+ OnDeleteRestrict -> "ON DELETE RESTRICT"
158+ OnDeleteCascade -> "ON DELETE CASCADE"
159+
160+data OnUpdate
161+ = OnUpdateNoAction
162+ | OnUpdateRestrict
163+ | OnUpdateCascade
164+ deriving (GHC.Generic,Show,Eq,Ord,Data)
165+instance NFData OnUpdate
166+
167+renderOnUpdate :: OnUpdate -> ByteString
168+renderOnUpdate = \case
169+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
170+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
171+ OnUpdateCascade -> "ON UPDATE CASCADE"
172+
173+{-----------------------------------------
174+DROP statements
175+-----------------------------------------}
176+
177+dropTable
178+ :: KnownSymbol table
179+ => Alias table
180+ -> Definition schema (Drop table schema)
181+dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
182+
183+{-----------------------------------------
184+ALTER statements
185+-----------------------------------------}
186+
187+alterTable
188+ :: HasTable table schema columns0
189+ => Alias table
190+ -> AlterTable columns0 columns1
191+ -> Definition schema (Alter table schema columns1)
192+alterTable table alteration = UnsafeDefinition $
193+ "ALTER TABLE"
194+ <+> renderAlias table
195+ <+> renderAlterTable alteration
196+ <> ";"
197+
198+alterTableRename
199+ :: (KnownSymbol table0, KnownSymbol table1)
200+ => Alias table0
201+ -> Alias table1
202+ -> Definition schema (Rename table0 table1 schema)
203+alterTableRename table0 table1 = UnsafeDefinition $
204+ "ALTER TABLE" <+> renderAlias table0
205+ <+> "RENAME TO" <+> renderAlias table1 <> ";"
206+
207+newtype AlterTable
208+ (columns0 :: ColumnsType)
209+ (columns1 :: ColumnsType) =
210+ UnsafeAlterTable {renderAlterTable :: ByteString}
211+ deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
212+
213+addColumnDefault
214+ :: KnownSymbol column
215+ => Alias column
216+ -> TypeExpression ('Optional ty)
217+ -> AlterTable columns (Create column ('Optional ty) columns)
218+addColumnDefault column ty = UnsafeAlterTable $
219+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
220+
221+addColumnNull
222+ :: KnownSymbol column
223+ => Alias column
224+ -> TypeExpression ('Required ('Null ty))
225+ -> AlterTable columns (Create column ('Required ('Null ty)) columns)
226+addColumnNull column ty = UnsafeAlterTable $
227+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
228+
229+dropColumn
230+ :: KnownSymbol column
231+ => Alias column
232+ -> AlterTable columns (Drop column columns)
233+dropColumn column = UnsafeAlterTable $
234+ "DROP COLUMN" <+> renderAlias column
235+
236+renameColumn
237+ :: (KnownSymbol column0, KnownSymbol column1)
238+ => Alias column0
239+ -> Alias column1
240+ -> AlterTable columns (Rename column0 column1 columns)
241+renameColumn column0 column1 = UnsafeAlterTable $
242+ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
243+
244+alterColumn
245+ :: (KnownSymbol column, HasColumn column columns ty0)
246+ => Alias column
247+ -> AlterColumn ty0 ty1
248+ -> AlterTable columns (Alter column columns ty1)
249+alterColumn column alteration = UnsafeAlterTable $
250+ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
251+
252+newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
253+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
254+ deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
255+
256+setDefault
257+ :: Expression '[] '[] 'Ungrouped ('Required ty)
258+ -> AlterColumn ('Required ty) ('Optional ty)
259+setDefault expression = UnsafeAlterColumn $
260+ "SET DEFAULT" <+> renderExpression expression
261+
262+dropDefault :: AlterColumn ('Optional ty) ('Required ty)
263+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
264+
265+setNotNull
266+ :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))
267+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
268+
269+dropNotNull
270+ :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))
271+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
272+
273+alterType
274+ :: TypeExpression (optionality (nullity ty1))
275+ -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))
276+alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Statement.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression.hsrenamed+43−846
@@ -23,13 +23,14 @@
23 , UndecidableInstances
23 , UndecidableInstances
24#-}
24#-}
25
25
26−module Squeal.PostgreSQL.Statement
26+module Squeal.PostgreSQL.Expression
27 ( -- * Column Expressions
27 ( -- * Column Expressions
28 Expression (UnsafeExpression, renderExpression)
28 Expression (UnsafeExpression, renderExpression)
29 , HasParameter (param)
29 , HasParameter (param)
30 , HasColumn (getColumn)
30 , HasColumn (getColumn)
31 , Column (Column)
31 , Column (Column)
32 , renderColumn
32 , renderColumn
33+ , GroupedBy (getGroup1, getGroup2)
33 -- ** Default
34 -- ** Default
34 , def
35 , def
35 , unDef
36 , unDef
@@ -99,28 +100,6 @@ module Squeal.PostgreSQL.Statement
99 -- * Tables
100 -- * Tables
100 , Table (UnsafeTable, renderTable)
101 , Table (UnsafeTable, renderTable)
101 , HasTable (getTable)
102 , HasTable (getTable)
102− -- ** Froms and Joins
103− , FromClause (..)
104− , renderFromClause
105− -- ** Table Expressions
106− , TableExpression (..)
107− , renderTableExpression
108− , from
109− , where_
110− , group
111− , having
112− , orderBy
113− , limit
114− , offset
115− , By (By, By2)
116− , renderBy
117− , GroupByClause (NoGroups, Group)
118− , renderGroupByClause
119− , HavingClause (NoHaving, Having)
120− , renderHavingClause
121− , GroupedBy (getGroup1, getGroup2)
122− , SortExpression (..)
123− , renderSortExpression
124 -- * TypeExpression
103 -- * TypeExpression
125 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
104 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
126 , PGTyped (pgtype)
105 , PGTyped (pgtype)
@@ -160,62 +139,6 @@ module Squeal.PostgreSQL.Statement
160 , jsonb
139 , jsonb
161 , notNull
140 , notNull
162 , default_
141 , default_
163− -- * Statements
164− -- ** Queries
165− , Query (UnsafeQuery, renderQuery)
166− , select
167− , selectDistinct
168− , selectStar
169− , selectDistinctStar
170− , selectDotStar
171− , selectDistinctDotStar
172− , union
173− , unionAll
174− , intersect
175− , intersectAll
176− , except
177− , exceptAll
178− -- ** Data Definition Language
179− , Definition (UnsafeDefinition, renderDefinition)
180− , createTable
181− , TableConstraint (UnsafeTableConstraint, renderTableConstraint)
182− , check
183− , unique
184− , primaryKey
185− , foreignKey
186− , OnDelete (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
187− , renderOnDelete
188− , OnUpdate (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
189− , renderOnUpdate
190− , dropTable
191− , alterTable
192− , alterTableRename
193− , AlterTable (UnsafeAlterTable, renderAlterTable)
194− , addColumnDefault
195− , addColumnNull
196− , dropColumn
197− , renameColumn
198− , alterColumn
199− , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
200− , setDefault
201− , dropDefault
202− , setNotNull
203− , dropNotNull
204− , alterType
205− -- ** Data Manipulation Language
206− , Manipulation (UnsafeManipulation, renderManipulation)
207− , queryStatement
208− , insertInto
209− , ValuesClause (Values, ValuesQuery)
210− , renderValuesClause
211− , ReturningClause (ReturningStar, Returning)
212− , renderReturningClause
213− , ConflictClause (Conflict, OnConflictDoNothing, OnConflictDoUpdate)
214− , renderConflictClause
215− , UpdateExpression (Same, Set)
216− , renderUpdateExpression
217− , update
218− , deleteFrom
219 -- * Re-export
142 -- * Re-export
220 , (&)
143 , (&)
221 , NP ((:*), Nil)
144 , NP ((:*), Nil)
@@ -225,22 +148,18 @@ import Control.Category
225import Control.DeepSeq
148import Control.DeepSeq
226import Data.ByteString (ByteString)
149import Data.ByteString (ByteString)
227import Data.Data (Data)
150import Data.Data (Data)
228−import Data.Foldable
229import Data.Function ((&))
151import Data.Function ((&))
230−import Data.Maybe
231import Data.Monoid hiding (All)
152import Data.Monoid hiding (All)
232import Data.Ratio
153import Data.Ratio
233import Data.String
154import Data.String
234−import Data.Word
235import Generics.SOP hiding (from)
155import Generics.SOP hiding (from)
236−import GHC.Exts
237import GHC.OverloadedLabels
156import GHC.OverloadedLabels
238import GHC.TypeLits
157import GHC.TypeLits
239import Prelude hiding (id, (.))
158import Prelude hiding (id, (.))
240
159
241import qualified GHC.Generics as GHC
160import qualified GHC.Generics as GHC
242−import qualified Data.ByteString as ByteString
243
161
162+import Squeal.PostgreSQL.Prettyprint
244import Squeal.PostgreSQL.Schema
163import Squeal.PostgreSQL.Schema
245
164
246{-----------------------------------------
165{-----------------------------------------
@@ -322,6 +241,46 @@ deriving instance Show (Column columns columnty)
322deriving instance Eq (Column columns columnty)
241deriving instance Eq (Column columns columnty)
323deriving instance Ord (Column columns columnty)
242deriving instance Ord (Column columns columnty)
324
243
244+renderColumn :: Column columns columnty -> ByteString
245+renderColumn (Column column) = renderAlias column
246+
247+class (KnownSymbol table, KnownSymbol column)
248+ => GroupedBy table column bys where
249+ getGroup1
250+ :: (HasUnique table tables columns, HasColumn column columns ty)
251+ => Alias column
252+ -> Expression params tables ('Grouped bys) ty
253+ getGroup1 column = UnsafeExpression $ renderAlias column
254+ getGroup2
255+ :: (HasTable table tables columns, HasColumn column columns ty)
256+ => Alias table
257+ -> Alias column
258+ -> Expression params tables ('Grouped bys) ty
259+ getGroup2 table column = UnsafeExpression $
260+ renderAlias table <> "." <> renderAlias column
261+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
262+ => GroupedBy table column ('(table,column) ': bys)
263+instance {-# OVERLAPPABLE #-}
264+ ( KnownSymbol table
265+ , KnownSymbol column
266+ , GroupedBy table column bys
267+ ) => GroupedBy table column (tabcol ': bys)
268+
269+instance
270+ ( HasUnique table tables columns
271+ , HasColumn column columns ty
272+ , GroupedBy table column bys
273+ ) => IsLabel column
274+ (Expression params tables ('Grouped bys) ty) where
275+ fromLabel = getGroup1 (Alias @column)
276+
277+instance
278+ ( HasTable table tables columns
279+ , HasColumn column columns ty
280+ , GroupedBy table column bys
281+ ) => IsTableColumn table column
282+ (Expression params tables ('Grouped bys) ty) where (!) = getGroup2
283+
325-- | >>> renderExpression def
284-- | >>> renderExpression def
326-- "DEFAULT"
285-- "DEFAULT"
327def :: Expression params '[] 'Ungrouped ('Optional (nullity ty))
286def :: Expression params '[] 'Ungrouped ('Optional (nullity ty))
@@ -667,138 +626,10 @@ localTimestamp
667 :: Expression params tables grouping ('Required (nullity 'PGtimestamp))
626 :: Expression params tables grouping ('Required (nullity 'PGtimestamp))
668localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
627localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
669
628
670−data SortExpression params tables grouping where
671− Asc
672− :: Expression params tables grouping ('Required ('NotNull ty))
673− -> SortExpression params tables grouping
674− Desc
675− :: Expression params tables grouping ('Required ('NotNull ty))
676− -> SortExpression params tables grouping
677− AscNullsFirst
678− :: Expression params tables grouping ('Required ('Null ty))
679− -> SortExpression params tables grouping
680− AscNullsLast
681− :: Expression params tables grouping ('Required ('Null ty))
682− -> SortExpression params tables grouping
683− DescNullsFirst
684− :: Expression params tables grouping ('Required ('Null ty))
685− -> SortExpression params tables grouping
686− DescNullsLast
687− :: Expression params tables grouping ('Required ('Null ty))
688− -> SortExpression params tables grouping
689−deriving instance Show (SortExpression params tables grouping)
690−
691−renderSortExpression :: SortExpression params tables grouping -> ByteString
692−renderSortExpression = \case
693− Asc expression -> renderExpression expression <+> "ASC"
694− Desc expression -> renderExpression expression <+> "DESC"
695− AscNullsFirst expression -> renderExpression expression
696− <+> "ASC NULLS FIRST"
697− DescNullsFirst expression -> renderExpression expression
698− <+> "DESC NULLS FIRST"
699− AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"
700− DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"
701−
702−
703{-----------------------------------------
629{-----------------------------------------
704aggregation
630aggregation
705-----------------------------------------}
631-----------------------------------------}
706
632
707−data By
708− (tables :: TablesType)
709− (by :: (Symbol,Symbol)) where
710− By
711− :: (HasUnique table tables columns, HasColumn column columns ty)
712− => Alias column
713− -> By tables '(table, column)
714− By2
715− :: (HasTable table tables columns, HasColumn column columns ty)
716− => (Alias table, Alias column)
717− -> By tables '(table, column)
718−deriving instance Show (By tables by)
719−deriving instance Eq (By tables by)
720−deriving instance Ord (By tables by)
721−
722−renderBy :: By tables tabcolty -> ByteString
723−renderBy = \case
724− By column -> renderAlias column
725− By2 (table, column) -> renderAlias table <> "." <> renderAlias column
726−
727−data GroupByClause tables grouping where
728− NoGroups :: GroupByClause tables 'Ungrouped
729− Group
730− :: SListI bys
731− => NP (By tables) bys
732− -> GroupByClause tables ('Grouped bys)
733−
734−renderGroupByClause :: GroupByClause tables grouping -> ByteString
735−renderGroupByClause = \case
736− NoGroups -> ""
737− Group Nil -> ""
738− Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
739−
740−data HavingClause params tables grouping where
741− NoHaving :: HavingClause params tables 'Ungrouped
742− Having
743− :: [Condition params tables ('Grouped bys)]
744− -> HavingClause params tables ('Grouped bys)
745−deriving instance Show (HavingClause params tables grouping)
746−deriving instance Eq (HavingClause params tables grouping)
747−deriving instance Ord (HavingClause params tables grouping)
748−
749−renderHavingClause :: HavingClause params tables grouping -> ByteString
750−renderHavingClause = \case
751− NoHaving -> ""
752− Having [] -> ""
753− Having conditions ->
754− " HAVING" <+> commaSeparated (renderExpression <$> conditions)
755−
756−class (KnownSymbol table, KnownSymbol column)
757− => GroupedBy table column bys where
758− getGroup1
759− :: (HasUnique table tables columns, HasColumn column columns ty)
760− => Alias column
761− -> Expression params tables ('Grouped bys) ty
762− getGroup1 column = UnsafeExpression $ renderAlias column
763− getGroup2
764− :: (HasTable table tables columns, HasColumn column columns ty)
765− => Alias table
766− -> Alias column
767− -> Expression params tables ('Grouped bys) ty
768− getGroup2 table column = UnsafeExpression $
769− renderAlias table <> "." <> renderAlias column
770−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
771− => GroupedBy table column ('(table,column) ': bys)
772−instance {-# OVERLAPPABLE #-}
773− ( KnownSymbol table
774− , KnownSymbol column
775− , GroupedBy table column bys
776− ) => GroupedBy table column (tabcol ': bys)
777−
778−instance
779− ( HasUnique table tables columns
780− , HasColumn column columns ty
781− , GroupedBy table column bys
782− ) => IsLabel column
783− (Expression params tables ('Grouped bys) ty) where
784− fromLabel = getGroup1 (Alias @column)
785−
786−instance
787− ( HasTable table tables columns
788− , HasColumn column columns ty
789− , GroupedBy table column bys
790− ) => IsTableColumn table column
791− (Expression params tables ('Grouped bys) ty) where (!) = getGroup2
792−
793−-- data AllOrDistinct = All | Distinct
794−-- deriving (GHC.Generic,Show,Eq,Ord,Data)
795−-- instance NFData AllOrDistinct
796−
797−-- renderAllOrDistinct :: AllOrDistinct -> ByteString
798−-- renderAllOrDistinct = \case
799−-- All -> "ALL"
800−-- Distinct -> "DISTINCT"
801−
802unsafeAggregate, unsafeAggregateDistinct
633unsafeAggregate, unsafeAggregateDistinct
803 :: ByteString
634 :: ByteString
804 -> Expression params tables 'Ungrouped ('Required xty)
635 -> Expression params tables 'Ungrouped ('Required xty)
@@ -913,149 +744,6 @@ instance HasTable table schema columns
913 => IsLabel table (Table schema columns) where
744 => IsLabel table (Table schema columns) where
914 fromLabel = getTable (Alias @table)
745 fromLabel = getTable (Alias @table)
915
746
916−data FromClause params schema tables where
917− Table
918− :: Aliased (Table schema) table
919− -> FromClause params schema '[table]
920− Subquery
921− :: Aliased (Query schema params) table
922− -> FromClause params schema '[table]
923− CrossJoin
924− :: FromClause params schema right
925− -> FromClause params schema left
926− -> FromClause params schema (Join left right)
927− InnerJoin
928− :: FromClause params schema right
929− -> Condition params (Join left right) 'Ungrouped
930− -> FromClause params schema left
931− -> FromClause params schema (Join left right)
932− LeftOuterJoin
933− :: FromClause params schema right
934− -> Condition params (Join left right) 'Ungrouped
935− -> FromClause params schema left
936− -> FromClause params schema (Join left (NullifyTables right))
937− RightOuterJoin
938− :: FromClause params schema right
939− -> Condition params (Join left right) 'Ungrouped
940− -> FromClause params schema left
941− -> FromClause params schema (Join (NullifyTables left) right)
942− FullOuterJoin
943− :: FromClause params schema right
944− -> Condition params (Join left right) 'Ungrouped
945− -> FromClause params schema left
946− -> FromClause params schema
947− (Join (NullifyTables left) (NullifyTables right))
948−
949−renderFromClause :: FromClause params schema tables -> ByteString
950−renderFromClause = \case
951− Table table -> renderAliased renderTable table
952− Subquery selection -> renderAliased (parenthesized . renderQuery) selection
953− CrossJoin right left ->
954− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
955− InnerJoin right on left -> renderJoin "INNER JOIN" right on left
956− LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left
957− RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left
958− FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left
959− where
960− renderJoin op right on left =
961− renderFromClause left <+> op <+> renderFromClause right
962− <+> "ON" <+> renderExpression on
963−
964−data TableExpression
965− (params :: [ColumnType])
966− (schema :: TablesType)
967− (tables :: TablesType)
968− (grouping :: Grouping)
969− = TableExpression
970− { fromClause :: FromClause params schema tables
971− , whereClause :: [Condition params tables 'Ungrouped]
972− , groupByClause :: GroupByClause tables grouping
973− , havingClause :: HavingClause params tables grouping
974− , orderByClause :: [SortExpression params tables grouping]
975− , limitClause :: [Word64]
976− , offsetClause :: [Word64]
977− }
978−
979−renderTableExpression
980− :: TableExpression params schema tables grouping
981− -> ByteString
982−renderTableExpression
983− (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat
984− [ "FROM ", renderFromClause tables
985− , renderWheres whs'
986− , renderGroupByClause grps'
987− , renderHavingClause hvs'
988− , renderSorts srts'
989− , renderLimits lims'
990− , renderOffsets offs'
991− ]
992− where
993− renderWheres = \case
994− [] -> ""
995− wh:[] -> " WHERE" <+> renderExpression wh
996− wh:whs -> " WHERE" <+> renderExpression (foldr (&&*) wh whs)
997− renderSorts = \case
998− [] -> ""
999− srts -> " SORT BY"
1000− <+> commaSeparated (renderSortExpression <$> srts)
1001− renderLimits = \case
1002− [] -> ""
1003− lims -> " LIMIT" <+> fromString (show (minimum lims))
1004− renderOffsets = \case
1005− [] -> ""
1006− offs -> " OFFSET" <+> fromString (show (sum offs))
1007−
1008−from
1009− :: FromClause params schema tables
1010− -> TableExpression params schema tables 'Ungrouped
1011−from tables = TableExpression tables [] NoGroups NoHaving [] [] []
1012−
1013−where_
1014− :: Condition params tables 'Ungrouped
1015− -> TableExpression params schema tables grouping
1016− -> TableExpression params schema tables grouping
1017−where_ wh tables = tables {whereClause = wh : whereClause tables}
1018−
1019−group
1020− :: SListI bys
1021− => NP (By tables) bys
1022− -> TableExpression params schema tables 'Ungrouped
1023− -> TableExpression params schema tables ('Grouped bys)
1024−group bys tables = TableExpression
1025− { fromClause = fromClause tables
1026− , whereClause = whereClause tables
1027− , groupByClause = Group bys
1028− , havingClause = Having []
1029− , orderByClause = []
1030− , limitClause = limitClause tables
1031− , offsetClause = offsetClause tables
1032− }
1033−
1034−having
1035− :: Condition params tables ('Grouped bys)
1036− -> TableExpression params schema tables ('Grouped bys)
1037− -> TableExpression params schema tables ('Grouped bys)
1038−having hv tables = tables
1039− { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }
1040−
1041−orderBy
1042− :: [SortExpression params tables grouping]
1043− -> TableExpression params schema tables grouping
1044− -> TableExpression params schema tables grouping
1045−orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}
1046−
1047−limit
1048− :: Word64
1049− -> TableExpression params schema tables grouping
1050− -> TableExpression params schema tables grouping
1051−limit lim tables = tables {limitClause = lim : limitClause tables}
1052−
1053−offset
1054− :: Word64
1055− -> TableExpression params schema tables grouping
1056− -> TableExpression params schema tables grouping
1057−offset off tables = tables {offsetClause = off : offsetClause tables}
1058−
1059{-----------------------------------------
747{-----------------------------------------
1060type expressions
748type expressions
1061-----------------------------------------}
749-----------------------------------------}
@@ -1181,494 +869,3 @@ instance PGTyped 'PGinterval where pgtype = interval
1181instance PGTyped 'PGuuid where pgtype = uuid
869instance PGTyped 'PGuuid where pgtype = uuid
1182instance PGTyped 'PGjson where pgtype = json
870instance PGTyped 'PGjson where pgtype = json
1183instance PGTyped 'PGjsonb where pgtype = jsonb
871instance PGTyped 'PGjsonb where pgtype = jsonb
1184−
1185−{-----------------------------------------
1186−statements
1187−-----------------------------------------}
1188−
1189−newtype Definition
1190− (schema0 :: TablesType)
1191− (schema1 :: TablesType)
1192− = UnsafeDefinition { renderDefinition :: ByteString }
1193− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1194−
1195−instance Category Definition where
1196− id = UnsafeDefinition ";"
1197− ddl1 . ddl0 = UnsafeDefinition $
1198− renderDefinition ddl0 <+> renderDefinition ddl1
1199−
1200−newtype Manipulation
1201− (schema :: TablesType)
1202− (params :: [ColumnType])
1203− (columns :: ColumnsType)
1204− = UnsafeManipulation { renderManipulation :: ByteString }
1205− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1206−
1207−newtype Query
1208− (schema :: TablesType)
1209− (params :: [ColumnType])
1210− (columns :: ColumnsType)
1211− = UnsafeQuery { renderQuery :: ByteString }
1212− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1213−
1214−queryStatement
1215− :: Query schema params columns
1216− -> Manipulation schema params columns
1217−queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
1218−
1219−union, unionAll, intersect, intersectAll, except, exceptAll
1220− :: Query schema params columns
1221− -> Query schema params columns
1222− -> Query schema params columns
1223−q1 `union` q2 = UnsafeQuery $
1224− parenthesized (renderQuery q1)
1225− <+> "UNION"
1226− <+> parenthesized (renderQuery q2)
1227−q1 `unionAll` q2 = UnsafeQuery $
1228− parenthesized (renderQuery q1)
1229− <+> "UNION" <+> "ALL"
1230− <+> parenthesized (renderQuery q2)
1231−q1 `intersect` q2 = UnsafeQuery $
1232− parenthesized (renderQuery q1)
1233− <+> "INTERSECT"
1234− <+> parenthesized (renderQuery q2)
1235−q1 `intersectAll` q2 = UnsafeQuery $
1236− parenthesized (renderQuery q1)
1237− <+> "INTERSECT" <+> "ALL"
1238− <+> parenthesized (renderQuery q2)
1239−q1 `except` q2 = UnsafeQuery $
1240− parenthesized (renderQuery q1)
1241− <+> "EXCEPT"
1242− <+> parenthesized (renderQuery q2)
1243−q1 `exceptAll` q2 = UnsafeQuery $
1244− parenthesized (renderQuery q1)
1245− <+> "EXCEPT" <+> "ALL"
1246− <+> parenthesized (renderQuery q2)
1247−
1248−{-----------------------------------------
1249−SELECT statements
1250−-----------------------------------------}
1251−
1252−select
1253− :: SListI columns
1254− => NP (Aliased (Expression params tables grouping)) (column ': columns)
1255− -> TableExpression params schema tables grouping
1256− -> Query schema params (column ': columns)
1257−select list tabs = UnsafeQuery $
1258− "SELECT"
1259− <+> renderCommaSeparated (renderAliased renderExpression) list
1260− <+> renderTableExpression tabs
1261−
1262−selectDistinct
1263− :: SListI columns
1264− => NP (Aliased (Expression params tables grouping)) (column ': columns)
1265− -> TableExpression params schema tables grouping
1266− -> Query schema params (column ': columns)
1267−selectDistinct list tabs = UnsafeQuery $
1268− "SELECT DISTINCT"
1269− <+> renderCommaSeparated (renderAliased renderExpression) list
1270− <+> renderTableExpression tabs
1271−
1272−selectStar
1273− :: HasUnique table tables columns
1274− => TableExpression params schema tables 'Ungrouped
1275− -> Query schema params columns
1276−selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs
1277−
1278−selectDistinctStar
1279− :: HasUnique table tables columns
1280− => TableExpression params schema tables 'Ungrouped
1281− -> Query schema params columns
1282−selectDistinctStar tabs = UnsafeQuery $
1283− "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs
1284−
1285−selectDotStar
1286− :: HasTable table tables columns
1287− => Alias table
1288− -> TableExpression params schema tables 'Ungrouped
1289− -> Query schema params columns
1290−selectDotStar table tables = UnsafeQuery $
1291− "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables
1292−
1293−selectDistinctDotStar
1294− :: HasTable table tables columns
1295− => Alias table
1296− -> TableExpression params schema tables 'Ungrouped
1297− -> Query schema params columns
1298−selectDistinctDotStar table tables = UnsafeQuery $
1299− "SELECT DISTINCT" <+> renderAlias table <> ".*"
1300− <+> renderTableExpression tables
1301−
1302−{-----------------------------------------
1303−CREATE statements
1304−-----------------------------------------}
1305−
1306−createTable
1307− :: (KnownSymbol table, SListI columns)
1308− => Alias table
1309− -> NP (Aliased TypeExpression) (column ': columns)
1310− -> [TableConstraint schema (column ': columns)]
1311− -> Definition schema (Create table (column ': columns) schema)
1312−createTable table columns constraints = UnsafeDefinition $
1313− "CREATE TABLE" <+> renderAlias table
1314− <+> parenthesized
1315− ( renderCommaSeparated renderColumnDef columns
1316− <> renderConstraints constraints )
1317− <> ";"
1318− where
1319− renderColumnDef :: Aliased TypeExpression x -> ByteString
1320− renderColumnDef (ty `As` column) =
1321− renderAlias column <+> renderTypeExpression ty
1322− renderConstraints :: [TableConstraint schema columns] -> ByteString
1323− renderConstraints = \case
1324− [] -> ""
1325− _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
1326−
1327−newtype TableConstraint
1328− (schema :: TablesType)
1329− (columns :: ColumnsType)
1330− = UnsafeTableConstraint { renderTableConstraint :: ByteString }
1331− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1332−
1333−check
1334− :: Condition '[] '[table ::: columns] 'Ungrouped
1335− -> TableConstraint schema columns
1336−check condition = UnsafeTableConstraint $
1337− "CHECK" <+> parenthesized (renderExpression condition)
1338−
1339−renderColumn :: Column columns columnty -> ByteString
1340−renderColumn (Column column) = renderAlias column
1341−
1342−unique
1343− :: SListI subcolumns
1344− => NP (Column columns) subcolumns
1345− -> TableConstraint schema columns
1346−unique columns = UnsafeTableConstraint $
1347− "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
1348−
1349−primaryKey
1350− :: (SListI subcolumns, AllNotNull subcolumns)
1351− => NP (Column columns) subcolumns
1352− -> TableConstraint schema columns
1353−primaryKey columns = UnsafeTableConstraint $
1354− "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
1355−
1356−foreignKey
1357− :: ( HasTable reftable schema refcolumns
1358− , SameTypes subcolumns refsubcolumns
1359− , NotAllNull subcolumns
1360− , SListI subcolumns
1361− , SListI refsubcolumns)
1362− => NP (Column columns) subcolumns
1363− -> Alias reftable
1364− -> NP (Column refcolumns) refsubcolumns
1365− -> OnDelete
1366− -> OnUpdate
1367− -> TableConstraint schema columns
1368−foreignKey columns reftable refcolumns onDelete onUpdate =
1369− UnsafeTableConstraint $
1370− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
1371− <+> "REFERENCES" <+> renderAlias reftable
1372− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
1373− <+> renderOnDelete onDelete
1374− <+> renderOnUpdate onUpdate
1375−
1376−data OnDelete
1377− = OnDeleteNoAction
1378− | OnDeleteRestrict
1379− | OnDeleteCascade
1380− deriving (GHC.Generic,Show,Eq,Ord,Data)
1381−instance NFData OnDelete
1382−
1383−renderOnDelete :: OnDelete -> ByteString
1384−renderOnDelete = \case
1385− OnDeleteNoAction -> "ON DELETE NO ACTION"
1386− OnDeleteRestrict -> "ON DELETE RESTRICT"
1387− OnDeleteCascade -> "ON DELETE CASCADE"
1388−
1389−data OnUpdate
1390− = OnUpdateNoAction
1391− | OnUpdateRestrict
1392− | OnUpdateCascade
1393− deriving (GHC.Generic,Show,Eq,Ord,Data)
1394−instance NFData OnUpdate
1395−
1396−renderOnUpdate :: OnUpdate -> ByteString
1397−renderOnUpdate = \case
1398− OnUpdateNoAction -> "ON UPDATE NO ACTION"
1399− OnUpdateRestrict -> "ON UPDATE RESTRICT"
1400− OnUpdateCascade -> "ON UPDATE CASCADE"
1401−
1402−{-----------------------------------------
1403−DROP statements
1404−-----------------------------------------}
1405−
1406−dropTable
1407− :: KnownSymbol table
1408− => Alias table
1409− -> Definition schema (Drop table schema)
1410−dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
1411−
1412−{-----------------------------------------
1413−ALTER statements
1414−-----------------------------------------}
1415−
1416−alterTable
1417− :: HasTable table schema columns0
1418− => Alias table
1419− -> AlterTable columns0 columns1
1420− -> Definition schema (Alter table schema columns1)
1421−alterTable table alteration = UnsafeDefinition $
1422− "ALTER TABLE"
1423− <+> renderAlias table
1424− <+> renderAlterTable alteration
1425− <> ";"
1426−
1427−alterTableRename
1428− :: (KnownSymbol table0, KnownSymbol table1)
1429− => Alias table0
1430− -> Alias table1
1431− -> Definition schema (Rename table0 table1 schema)
1432−alterTableRename table0 table1 = UnsafeDefinition $
1433− "ALTER TABLE" <+> renderAlias table0
1434− <+> "RENAME TO" <+> renderAlias table1 <> ";"
1435−
1436−newtype AlterTable
1437− (columns0 :: ColumnsType)
1438− (columns1 :: ColumnsType) =
1439− UnsafeAlterTable {renderAlterTable :: ByteString}
1440− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1441−
1442−addColumnDefault
1443− :: KnownSymbol column
1444− => Alias column
1445− -> TypeExpression ('Optional ty)
1446− -> AlterTable columns (Create column ('Optional ty) columns)
1447−addColumnDefault column ty = UnsafeAlterTable $
1448− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
1449−
1450−addColumnNull
1451− :: KnownSymbol column
1452− => Alias column
1453− -> TypeExpression ('Required ('Null ty))
1454− -> AlterTable columns (Create column ('Required ('Null ty)) columns)
1455−addColumnNull column ty = UnsafeAlterTable $
1456− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
1457−
1458−dropColumn
1459− :: KnownSymbol column
1460− => Alias column
1461− -> AlterTable columns (Drop column columns)
1462−dropColumn column = UnsafeAlterTable $
1463− "DROP COLUMN" <+> renderAlias column
1464−
1465−renameColumn
1466− :: (KnownSymbol column0, KnownSymbol column1)
1467− => Alias column0
1468− -> Alias column1
1469− -> AlterTable columns (Rename column0 column1 columns)
1470−renameColumn column0 column1 = UnsafeAlterTable $
1471− "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
1472−
1473−alterColumn
1474− :: (KnownSymbol column, HasColumn column columns ty0)
1475− => Alias column
1476− -> AlterColumn ty0 ty1
1477− -> AlterTable columns (Alter column columns ty1)
1478−alterColumn column alteration = UnsafeAlterTable $
1479− "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
1480−
1481−newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
1482− UnsafeAlterColumn {renderAlterColumn :: ByteString}
1483− deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
1484−
1485−setDefault
1486− :: Expression '[] '[] 'Ungrouped ('Required ty)
1487− -> AlterColumn ('Required ty) ('Optional ty)
1488−setDefault expression = UnsafeAlterColumn $
1489− "SET DEFAULT" <+> renderExpression expression
1490−
1491−dropDefault :: AlterColumn ('Optional ty) ('Required ty)
1492−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
1493−
1494−setNotNull
1495− :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))
1496−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
1497−
1498−dropNotNull
1499− :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))
1500−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
1501−
1502−alterType
1503− :: TypeExpression (optionality (nullity ty1))
1504− -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))
1505−alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty
1506−
1507−{-----------------------------------------
1508−INSERT statements
1509−-----------------------------------------}
1510−
1511−insertInto
1512− :: (SListI columns, SListI results, HasTable table schema columns)
1513− => Alias table
1514− -> ValuesClause schema params columns
1515− -> ConflictClause params columns
1516− -> ReturningClause params columns results
1517− -> Manipulation schema params results
1518−insertInto table insert conflict returning = UnsafeManipulation $
1519− "INSERT" <+> "INTO" <+> renderAlias table
1520− <+> renderValuesClause insert
1521− <> renderConflictClause conflict
1522− <> renderReturningClause returning
1523−
1524−data ValuesClause
1525− (schema :: TablesType)
1526− (params :: [ColumnType])
1527− (columns :: ColumnsType)
1528− = Values
1529− (NP (Aliased (Expression params '[] 'Ungrouped)) columns)
1530− [NP (Aliased (Expression params '[] 'Ungrouped)) columns]
1531− | ValuesQuery (Query schema params columns)
1532−
1533−renderValuesClause
1534− :: SListI columns
1535− => ValuesClause schema params columns
1536− -> ByteString
1537−renderValuesClause = \case
1538− Values row rows ->
1539− parenthesized (renderCommaSeparated renderAliasPart row)
1540− <+> "VALUES"
1541− <+> commaSeparated
1542− (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)
1543− where
1544− renderAliasPart, renderValuePart
1545− :: Aliased (Expression params '[] 'Ungrouped) ty -> ByteString
1546− renderAliasPart (_ `As` name) = renderAlias name
1547− renderValuePart (value `As` _) = renderExpression value
1548− ValuesQuery q -> renderQuery q
1549−
1550−data ReturningClause
1551− (params :: [ColumnType])
1552− (columns :: ColumnsType)
1553− (results :: ColumnsType)
1554− where
1555− ReturningStar :: ReturningClause params columns columns
1556− Returning
1557− :: NP
1558− (Aliased (Expression params '[table ::: columns] 'Ungrouped))
1559− results
1560− -> ReturningClause params columns results
1561−
1562−renderReturningClause
1563− :: SListI results
1564− => ReturningClause params columns results
1565− -> ByteString
1566−renderReturningClause = \case
1567− ReturningStar -> " RETURNING *;"
1568− Returning Nil -> ";"
1569− Returning results -> " RETURNING"
1570− <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"
1571−
1572−data ConflictClause params columns where
1573− Conflict :: ConflictClause params columns
1574− OnConflictDoNothing :: ConflictClause params columns
1575− OnConflictDoUpdate
1576− :: NP (Aliased (UpdateExpression params columns)) columns
1577− -> Maybe (Condition params '[table ::: columns] 'Ungrouped)
1578− -> ConflictClause params columns
1579−
1580−renderConflictClause
1581− :: SListI columns
1582− => ConflictClause params columns
1583− -> ByteString
1584−renderConflictClause = \case
1585− Conflict -> ""
1586− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
1587− OnConflictDoUpdate updates whMaybe
1588− -> " ON CONFLICT DO UPDATE SET"
1589− <+> renderCommaSeparatedMaybe renderUpdateExpression updates
1590− <> case whMaybe of
1591− Nothing -> ""
1592− Just wh -> " WHERE" <+> renderExpression wh
1593−
1594−{-----------------------------------------
1595−UPDATE statements
1596−-----------------------------------------}
1597−
1598−data UpdateExpression params columns ty
1599− = Same
1600− | Set (forall table. Expression params '[table ::: columns] 'Ungrouped ty)
1601−deriving instance Show (UpdateExpression params columns ty)
1602−deriving instance Eq (UpdateExpression params columns ty)
1603−deriving instance Ord (UpdateExpression params columns ty)
1604−
1605−renderUpdateExpression
1606− :: Aliased (UpdateExpression params columns) column
1607− -> Maybe ByteString
1608−renderUpdateExpression = \case
1609− Same `As` _ -> Nothing
1610− Set expression `As` column -> Just $
1611− renderAlias column <+> "=" <+> renderExpression expression
1612−
1613−update
1614− :: (HasTable table schema columns, SListI columns, SListI results)
1615− => Alias table
1616− -> NP (Aliased (UpdateExpression params columns)) columns
1617− -> Condition params '[tab ::: columns] 'Ungrouped
1618− -> ReturningClause params columns results
1619− -> Manipulation schema params results
1620−update table columns wh returning = UnsafeManipulation $
1621− "UPDATE"
1622− <+> renderAlias table
1623− <+> "SET"
1624− <+> renderCommaSeparatedMaybe renderUpdateExpression columns
1625− <+> "WHERE" <+> renderExpression wh
1626− <> renderReturningClause returning
1627−
1628−{-----------------------------------------
1629−DELETE statements
1630−-----------------------------------------}
1631−
1632−deleteFrom
1633− :: HasTable table schema columns
1634− => Alias table
1635− -> Condition params '[table ::: columns] 'Ungrouped
1636− -> Manipulation schema params '[]
1637−deleteFrom table wh = UnsafeManipulation $
1638− "DELETE FROM" <+> renderAlias table
1639− <+> "WHERE" <+> renderExpression wh <> ";"
1640−
1641−{-----------------------------------------
1642−render helper functions
1643−-----------------------------------------}
1644−
1645−parenthesized :: ByteString -> ByteString
1646−parenthesized str = "(" <> str <> ")"
1647−
1648−(<+>) :: ByteString -> ByteString -> ByteString
1649−str1 <+> str2 = str1 <> " " <> str2
1650−
1651−commaSeparated :: [ByteString] -> ByteString
1652−commaSeparated = ByteString.intercalate ", "
1653−
1654−renderCommaSeparated
1655− :: SListI xs
1656− => (forall x. expression x -> ByteString)
1657− -> NP expression xs -> ByteString
1658−renderCommaSeparated render
1659− = commaSeparated
1660− . hcollapse
1661− . hmap (K . render)
1662−
1663−renderCommaSeparatedMaybe
1664− :: SListI xs
1665− => (forall x. expression x -> Maybe ByteString)
1666− -> NP expression xs -> ByteString
1667−renderCommaSeparatedMaybe render
1668− = commaSeparated
1669− . catMaybes
1670− . hcollapse
1671− . hmap (K . render)
1672−
1673−renderNat :: KnownNat n => proxy n -> ByteString
1674−renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hsnew file+193
@@ -0,0 +1,193 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveDataTypeable
4+ , DeriveGeneric
5+ , GADTs
6+ , GeneralizedNewtypeDeriving
7+ , KindSignatures
8+ , LambdaCase
9+ , OverloadedStrings
10+ , RankNTypes
11+ , StandaloneDeriving
12+ , TypeInType
13+ , TypeOperators
14+#-}
15+
16+module Squeal.PostgreSQL.Manipulation
17+ ( -- * Data Manipulation Language
18+ Manipulation (UnsafeManipulation, renderManipulation)
19+ , queryStatement
20+ , insertInto
21+ , ValuesClause (Values, ValuesQuery)
22+ , renderValuesClause
23+ , ReturningClause (ReturningStar, Returning)
24+ , renderReturningClause
25+ , ConflictClause (Conflict, OnConflictDoNothing, OnConflictDoUpdate)
26+ , renderConflictClause
27+ , UpdateExpression (Same, Set)
28+ , renderUpdateExpression
29+ , update
30+ , deleteFrom
31+ ) where
32+
33+-- import Control.Category
34+import Control.DeepSeq
35+import Data.ByteString
36+import Data.Data
37+import Data.Monoid
38+import Generics.SOP
39+-- import GHC.TypeLits
40+-- import Prelude hiding ((.), id)
41+
42+import qualified GHC.Generics as GHC
43+
44+import Squeal.PostgreSQL.Expression
45+import Squeal.PostgreSQL.Prettyprint
46+import Squeal.PostgreSQL.Query
47+import Squeal.PostgreSQL.Schema
48+
49+newtype Manipulation
50+ (schema :: TablesType)
51+ (params :: [ColumnType])
52+ (columns :: ColumnsType)
53+ = UnsafeManipulation { renderManipulation :: ByteString }
54+ deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
55+
56+queryStatement
57+ :: Query schema params columns
58+ -> Manipulation schema params columns
59+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
60+
61+{-----------------------------------------
62+INSERT statements
63+-----------------------------------------}
64+
65+insertInto
66+ :: (SListI columns, SListI results, HasTable table schema columns)
67+ => Alias table
68+ -> ValuesClause schema params columns
69+ -> ConflictClause params columns
70+ -> ReturningClause params columns results
71+ -> Manipulation schema params results
72+insertInto table insert conflict returning = UnsafeManipulation $
73+ "INSERT" <+> "INTO" <+> renderAlias table
74+ <+> renderValuesClause insert
75+ <> renderConflictClause conflict
76+ <> renderReturningClause returning
77+
78+data ValuesClause
79+ (schema :: TablesType)
80+ (params :: [ColumnType])
81+ (columns :: ColumnsType)
82+ = Values
83+ (NP (Aliased (Expression params '[] 'Ungrouped)) columns)
84+ [NP (Aliased (Expression params '[] 'Ungrouped)) columns]
85+ | ValuesQuery (Query schema params columns)
86+
87+renderValuesClause
88+ :: SListI columns
89+ => ValuesClause schema params columns
90+ -> ByteString
91+renderValuesClause = \case
92+ Values row rows ->
93+ parenthesized (renderCommaSeparated renderAliasPart row)
94+ <+> "VALUES"
95+ <+> commaSeparated
96+ (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)
97+ where
98+ renderAliasPart, renderValuePart
99+ :: Aliased (Expression params '[] 'Ungrouped) ty -> ByteString
100+ renderAliasPart (_ `As` name) = renderAlias name
101+ renderValuePart (value `As` _) = renderExpression value
102+ ValuesQuery q -> renderQuery q
103+
104+data ReturningClause
105+ (params :: [ColumnType])
106+ (columns :: ColumnsType)
107+ (results :: ColumnsType)
108+ where
109+ ReturningStar :: ReturningClause params columns columns
110+ Returning
111+ :: NP
112+ (Aliased (Expression params '[table ::: columns] 'Ungrouped))
113+ results
114+ -> ReturningClause params columns results
115+
116+renderReturningClause
117+ :: SListI results
118+ => ReturningClause params columns results
119+ -> ByteString
120+renderReturningClause = \case
121+ ReturningStar -> " RETURNING *;"
122+ Returning Nil -> ";"
123+ Returning results -> " RETURNING"
124+ <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"
125+
126+data ConflictClause params columns where
127+ Conflict :: ConflictClause params columns
128+ OnConflictDoNothing :: ConflictClause params columns
129+ OnConflictDoUpdate
130+ :: NP (Aliased (UpdateExpression params columns)) columns
131+ -> Maybe (Condition params '[table ::: columns] 'Ungrouped)
132+ -> ConflictClause params columns
133+
134+renderConflictClause
135+ :: SListI columns
136+ => ConflictClause params columns
137+ -> ByteString
138+renderConflictClause = \case
139+ Conflict -> ""
140+ OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
141+ OnConflictDoUpdate updates whMaybe
142+ -> " ON CONFLICT DO UPDATE SET"
143+ <+> renderCommaSeparatedMaybe renderUpdateExpression updates
144+ <> case whMaybe of
145+ Nothing -> ""
146+ Just wh -> " WHERE" <+> renderExpression wh
147+
148+{-----------------------------------------
149+UPDATE statements
150+-----------------------------------------}
151+
152+data UpdateExpression params columns ty
153+ = Same
154+ | Set (forall table. Expression params '[table ::: columns] 'Ungrouped ty)
155+deriving instance Show (UpdateExpression params columns ty)
156+deriving instance Eq (UpdateExpression params columns ty)
157+deriving instance Ord (UpdateExpression params columns ty)
158+
159+renderUpdateExpression
160+ :: Aliased (UpdateExpression params columns) column
161+ -> Maybe ByteString
162+renderUpdateExpression = \case
163+ Same `As` _ -> Nothing
164+ Set expression `As` column -> Just $
165+ renderAlias column <+> "=" <+> renderExpression expression
166+
167+update
168+ :: (HasTable table schema columns, SListI columns, SListI results)
169+ => Alias table
170+ -> NP (Aliased (UpdateExpression params columns)) columns
171+ -> Condition params '[tab ::: columns] 'Ungrouped
172+ -> ReturningClause params columns results
173+ -> Manipulation schema params results
174+update table columns wh returning = UnsafeManipulation $
175+ "UPDATE"
176+ <+> renderAlias table
177+ <+> "SET"
178+ <+> renderCommaSeparatedMaybe renderUpdateExpression columns
179+ <+> "WHERE" <+> renderExpression wh
180+ <> renderReturningClause returning
181+
182+{-----------------------------------------
183+DELETE statements
184+-----------------------------------------}
185+
186+deleteFrom
187+ :: HasTable table schema columns
188+ => Alias table
189+ -> Condition params '[table ::: columns] 'Ungrouped
190+ -> Manipulation schema params '[]
191+deleteFrom table wh = UnsafeManipulation $
192+ "DELETE FROM" <+> renderAlias table
193+ <+> "WHERE" <+> renderExpression wh <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+3−1
@@ -38,7 +38,9 @@ import GHC.TypeLits
38import qualified Database.PostgreSQL.LibPQ as LibPQ
38import qualified Database.PostgreSQL.LibPQ as LibPQ
39
39
40import Squeal.PostgreSQL.Binary
40import Squeal.PostgreSQL.Binary
41−import Squeal.PostgreSQL.Statement
41+import Squeal.PostgreSQL.Definition
42+import Squeal.PostgreSQL.Manipulation
43+import Squeal.PostgreSQL.Query
42import Squeal.PostgreSQL.Schema
44import Squeal.PostgreSQL.Schema
43
45
44-- | A `Connection` consists of a `Database.PastgreSQL.LibPQ.Connection`
46-- | A `Connection` consists of a `Database.PastgreSQL.LibPQ.Connection`
squeal-postgresql/src/Squeal/PostgreSQL/Prettyprint.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE
2+ MagicHash
3+ , OverloadedStrings
4+ , PolyKinds
5+ , RankNTypes
6+ , ScopedTypeVariables
7+ , TypeApplications
8+#-}
9+
10+module Squeal.PostgreSQL.Prettyprint where
11+
12+import Data.ByteString (ByteString)
13+import Data.Maybe
14+import Data.Monoid ((<>))
15+import Generics.SOP
16+import GHC.Exts
17+import GHC.TypeLits
18+
19+import qualified Data.ByteString as ByteString
20+
21+parenthesized :: ByteString -> ByteString
22+parenthesized str = "(" <> str <> ")"
23+
24+(<+>) :: ByteString -> ByteString -> ByteString
25+str1 <+> str2 = str1 <> " " <> str2
26+
27+commaSeparated :: [ByteString] -> ByteString
28+commaSeparated = ByteString.intercalate ", "
29+
30+renderCommaSeparated
31+ :: SListI xs
32+ => (forall x. expression x -> ByteString)
33+ -> NP expression xs -> ByteString
34+renderCommaSeparated render
35+ = commaSeparated
36+ . hcollapse
37+ . hmap (K . render)
38+
39+renderCommaSeparatedMaybe
40+ :: SListI xs
41+ => (forall x. expression x -> Maybe ByteString)
42+ -> NP expression xs -> ByteString
43+renderCommaSeparatedMaybe render
44+ = commaSeparated
45+ . catMaybes
46+ . hcollapse
47+ . hmap (K . render)
48+
49+renderNat :: KnownNat n => proxy n -> ByteString
50+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
squeal-postgresql/src/Squeal/PostgreSQL/Query.hsnew file+405
@@ -0,0 +1,405 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , DeriveDataTypeable
4+ , DeriveGeneric
5+ , FlexibleInstances
6+ , GADTs
7+ , GeneralizedNewtypeDeriving
8+ , KindSignatures
9+ , LambdaCase
10+ , MultiParamTypeClasses
11+ , OverloadedStrings
12+ , ScopedTypeVariables
13+ , StandaloneDeriving
14+ , TypeApplications
15+ , TypeInType
16+ , TypeOperators
17+ , UndecidableInstances
18+#-}
19+
20+module Squeal.PostgreSQL.Query
21+ ( -- * Queries
22+ Query (UnsafeQuery, renderQuery)
23+ , union
24+ , unionAll
25+ , intersect
26+ , intersectAll
27+ , except
28+ , exceptAll
29+ -- * SELECT queries
30+ , select
31+ , selectDistinct
32+ , selectStar
33+ , selectDistinctStar
34+ , selectDotStar
35+ , selectDistinctDotStar
36+ -- * FROM clauses
37+ , FromClause (..)
38+ , renderFromClause
39+ -- * Table Expressions
40+ , TableExpression (..)
41+ , renderTableExpression
42+ , from
43+ , where_
44+ , group
45+ , having
46+ , orderBy
47+ , limit
48+ , offset
49+ , By (By, By2)
50+ , renderBy
51+ -- * Grouping
52+ , GroupByClause (NoGroups, Group)
53+ , renderGroupByClause
54+ , HavingClause (NoHaving, Having)
55+ , renderHavingClause
56+ , GroupedBy (getGroup1, getGroup2)
57+ -- * Sorting
58+ , SortExpression (..)
59+ , renderSortExpression
60+ ) where
61+
62+import Control.DeepSeq
63+import Data.ByteString (ByteString)
64+import Data.Data
65+import Data.Monoid
66+import Data.String
67+import Data.Word
68+import Generics.SOP hiding (from)
69+import GHC.TypeLits
70+
71+import qualified GHC.Generics as GHC
72+
73+import Squeal.PostgreSQL.Expression
74+import Squeal.PostgreSQL.Prettyprint
75+import Squeal.PostgreSQL.Schema
76+
77+newtype Query
78+ (schema :: TablesType)
79+ (params :: [ColumnType])
80+ (columns :: ColumnsType)
81+ = UnsafeQuery { renderQuery :: ByteString }
82+ deriving (GHC.Generic,Show,Eq,Ord,Data,NFData)
83+
84+union, unionAll, intersect, intersectAll, except, exceptAll
85+ :: Query schema params columns
86+ -> Query schema params columns
87+ -> Query schema params columns
88+q1 `union` q2 = UnsafeQuery $
89+ parenthesized (renderQuery q1)
90+ <+> "UNION"
91+ <+> parenthesized (renderQuery q2)
92+q1 `unionAll` q2 = UnsafeQuery $
93+ parenthesized (renderQuery q1)
94+ <+> "UNION" <+> "ALL"
95+ <+> parenthesized (renderQuery q2)
96+q1 `intersect` q2 = UnsafeQuery $
97+ parenthesized (renderQuery q1)
98+ <+> "INTERSECT"
99+ <+> parenthesized (renderQuery q2)
100+q1 `intersectAll` q2 = UnsafeQuery $
101+ parenthesized (renderQuery q1)
102+ <+> "INTERSECT" <+> "ALL"
103+ <+> parenthesized (renderQuery q2)
104+q1 `except` q2 = UnsafeQuery $
105+ parenthesized (renderQuery q1)
106+ <+> "EXCEPT"
107+ <+> parenthesized (renderQuery q2)
108+q1 `exceptAll` q2 = UnsafeQuery $
109+ parenthesized (renderQuery q1)
110+ <+> "EXCEPT" <+> "ALL"
111+ <+> parenthesized (renderQuery q2)
112+
113+{-----------------------------------------
114+SELECT queries
115+-----------------------------------------}
116+
117+select
118+ :: SListI columns
119+ => NP (Aliased (Expression params tables grouping)) (column ': columns)
120+ -> TableExpression params schema tables grouping
121+ -> Query schema params (column ': columns)
122+select list tabs = UnsafeQuery $
123+ "SELECT"
124+ <+> renderCommaSeparated (renderAliased renderExpression) list
125+ <+> renderTableExpression tabs
126+
127+selectDistinct
128+ :: SListI columns
129+ => NP (Aliased (Expression params tables grouping)) (column ': columns)
130+ -> TableExpression params schema tables grouping
131+ -> Query schema params (column ': columns)
132+selectDistinct list tabs = UnsafeQuery $
133+ "SELECT DISTINCT"
134+ <+> renderCommaSeparated (renderAliased renderExpression) list
135+ <+> renderTableExpression tabs
136+
137+selectStar
138+ :: HasUnique table tables columns
139+ => TableExpression params schema tables 'Ungrouped
140+ -> Query schema params columns
141+selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs
142+
143+selectDistinctStar
144+ :: HasUnique table tables columns
145+ => TableExpression params schema tables 'Ungrouped
146+ -> Query schema params columns
147+selectDistinctStar tabs = UnsafeQuery $
148+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs
149+
150+selectDotStar
151+ :: HasTable table tables columns
152+ => Alias table
153+ -> TableExpression params schema tables 'Ungrouped
154+ -> Query schema params columns
155+selectDotStar table tables = UnsafeQuery $
156+ "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables
157+
158+selectDistinctDotStar
159+ :: HasTable table tables columns
160+ => Alias table
161+ -> TableExpression params schema tables 'Ungrouped
162+ -> Query schema params columns
163+selectDistinctDotStar table tables = UnsafeQuery $
164+ "SELECT DISTINCT" <+> renderAlias table <> ".*"
165+ <+> renderTableExpression tables
166+
167+{-----------------------------------------
168+FROM clauses
169+-----------------------------------------}
170+
171+data FromClause params schema tables where
172+ Table
173+ :: Aliased (Table schema) table
174+ -> FromClause params schema '[table]
175+ Subquery
176+ :: Aliased (Query schema params) table
177+ -> FromClause params schema '[table]
178+ CrossJoin
179+ :: FromClause params schema right
180+ -> FromClause params schema left
181+ -> FromClause params schema (Join left right)
182+ InnerJoin
183+ :: FromClause params schema right
184+ -> Condition params (Join left right) 'Ungrouped
185+ -> FromClause params schema left
186+ -> FromClause params schema (Join left right)
187+ LeftOuterJoin
188+ :: FromClause params schema right
189+ -> Condition params (Join left right) 'Ungrouped
190+ -> FromClause params schema left
191+ -> FromClause params schema (Join left (NullifyTables right))
192+ RightOuterJoin
193+ :: FromClause params schema right
194+ -> Condition params (Join left right) 'Ungrouped
195+ -> FromClause params schema left
196+ -> FromClause params schema (Join (NullifyTables left) right)
197+ FullOuterJoin
198+ :: FromClause params schema right
199+ -> Condition params (Join left right) 'Ungrouped
200+ -> FromClause params schema left
201+ -> FromClause params schema
202+ (Join (NullifyTables left) (NullifyTables right))
203+
204+renderFromClause :: FromClause params schema tables -> ByteString
205+renderFromClause = \case
206+ Table table -> renderAliased renderTable table
207+ Subquery selection -> renderAliased (parenthesized . renderQuery) selection
208+ CrossJoin right left ->
209+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
210+ InnerJoin right on left -> renderJoin "INNER JOIN" right on left
211+ LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left
212+ RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left
213+ FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left
214+ where
215+ renderJoin op right on left =
216+ renderFromClause left <+> op <+> renderFromClause right
217+ <+> "ON" <+> renderExpression on
218+
219+{-----------------------------------------
220+Table Expressions
221+-----------------------------------------}
222+
223+data TableExpression
224+ (params :: [ColumnType])
225+ (schema :: TablesType)
226+ (tables :: TablesType)
227+ (grouping :: Grouping)
228+ = TableExpression
229+ { fromClause :: FromClause params schema tables
230+ , whereClause :: [Condition params tables 'Ungrouped]
231+ , groupByClause :: GroupByClause tables grouping
232+ , havingClause :: HavingClause params tables grouping
233+ , orderByClause :: [SortExpression params tables grouping]
234+ , limitClause :: [Word64]
235+ , offsetClause :: [Word64]
236+ }
237+
238+renderTableExpression
239+ :: TableExpression params schema tables grouping
240+ -> ByteString
241+renderTableExpression
242+ (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat
243+ [ "FROM ", renderFromClause tables
244+ , renderWheres whs'
245+ , renderGroupByClause grps'
246+ , renderHavingClause hvs'
247+ , renderSorts srts'
248+ , renderLimits lims'
249+ , renderOffsets offs'
250+ ]
251+ where
252+ renderWheres = \case
253+ [] -> ""
254+ wh:[] -> " WHERE" <+> renderExpression wh
255+ wh:whs -> " WHERE" <+> renderExpression (foldr (&&*) wh whs)
256+ renderSorts = \case
257+ [] -> ""
258+ srts -> " SORT BY"
259+ <+> commaSeparated (renderSortExpression <$> srts)
260+ renderLimits = \case
261+ [] -> ""
262+ lims -> " LIMIT" <+> fromString (show (minimum lims))
263+ renderOffsets = \case
264+ [] -> ""
265+ offs -> " OFFSET" <+> fromString (show (sum offs))
266+
267+from
268+ :: FromClause params schema tables
269+ -> TableExpression params schema tables 'Ungrouped
270+from tables = TableExpression tables [] NoGroups NoHaving [] [] []
271+
272+where_
273+ :: Condition params tables 'Ungrouped
274+ -> TableExpression params schema tables grouping
275+ -> TableExpression params schema tables grouping
276+where_ wh tables = tables {whereClause = wh : whereClause tables}
277+
278+group
279+ :: SListI bys
280+ => NP (By tables) bys
281+ -> TableExpression params schema tables 'Ungrouped
282+ -> TableExpression params schema tables ('Grouped bys)
283+group bys tables = TableExpression
284+ { fromClause = fromClause tables
285+ , whereClause = whereClause tables
286+ , groupByClause = Group bys
287+ , havingClause = Having []
288+ , orderByClause = []
289+ , limitClause = limitClause tables
290+ , offsetClause = offsetClause tables
291+ }
292+
293+having
294+ :: Condition params tables ('Grouped bys)
295+ -> TableExpression params schema tables ('Grouped bys)
296+ -> TableExpression params schema tables ('Grouped bys)
297+having hv tables = tables
298+ { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }
299+
300+orderBy
301+ :: [SortExpression params tables grouping]
302+ -> TableExpression params schema tables grouping
303+ -> TableExpression params schema tables grouping
304+orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}
305+
306+limit
307+ :: Word64
308+ -> TableExpression params schema tables grouping
309+ -> TableExpression params schema tables grouping
310+limit lim tables = tables {limitClause = lim : limitClause tables}
311+
312+offset
313+ :: Word64
314+ -> TableExpression params schema tables grouping
315+ -> TableExpression params schema tables grouping
316+offset off tables = tables {offsetClause = off : offsetClause tables}
317+
318+{-----------------------------------------
319+Grouping
320+-----------------------------------------}
321+
322+data By
323+ (tables :: TablesType)
324+ (by :: (Symbol,Symbol)) where
325+ By
326+ :: (HasUnique table tables columns, HasColumn column columns ty)
327+ => Alias column
328+ -> By tables '(table, column)
329+ By2
330+ :: (HasTable table tables columns, HasColumn column columns ty)
331+ => (Alias table, Alias column)
332+ -> By tables '(table, column)
333+deriving instance Show (By tables by)
334+deriving instance Eq (By tables by)
335+deriving instance Ord (By tables by)
336+
337+renderBy :: By tables tabcolty -> ByteString
338+renderBy = \case
339+ By column -> renderAlias column
340+ By2 (table, column) -> renderAlias table <> "." <> renderAlias column
341+
342+data GroupByClause tables grouping where
343+ NoGroups :: GroupByClause tables 'Ungrouped
344+ Group
345+ :: SListI bys
346+ => NP (By tables) bys
347+ -> GroupByClause tables ('Grouped bys)
348+
349+renderGroupByClause :: GroupByClause tables grouping -> ByteString
350+renderGroupByClause = \case
351+ NoGroups -> ""
352+ Group Nil -> ""
353+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
354+
355+data HavingClause params tables grouping where
356+ NoHaving :: HavingClause params tables 'Ungrouped
357+ Having
358+ :: [Condition params tables ('Grouped bys)]
359+ -> HavingClause params tables ('Grouped bys)
360+deriving instance Show (HavingClause params tables grouping)
361+deriving instance Eq (HavingClause params tables grouping)
362+deriving instance Ord (HavingClause params tables grouping)
363+
364+renderHavingClause :: HavingClause params tables grouping -> ByteString
365+renderHavingClause = \case
366+ NoHaving -> ""
367+ Having [] -> ""
368+ Having conditions ->
369+ " HAVING" <+> commaSeparated (renderExpression <$> conditions)
370+
371+{-----------------------------------------
372+Sorting
373+-----------------------------------------}
374+
375+data SortExpression params tables grouping where
376+ Asc
377+ :: Expression params tables grouping ('Required ('NotNull ty))
378+ -> SortExpression params tables grouping
379+ Desc
380+ :: Expression params tables grouping ('Required ('NotNull ty))
381+ -> SortExpression params tables grouping
382+ AscNullsFirst
383+ :: Expression params tables grouping ('Required ('Null ty))
384+ -> SortExpression params tables grouping
385+ AscNullsLast
386+ :: Expression params tables grouping ('Required ('Null ty))
387+ -> SortExpression params tables grouping
388+ DescNullsFirst
389+ :: Expression params tables grouping ('Required ('Null ty))
390+ -> SortExpression params tables grouping
391+ DescNullsLast
392+ :: Expression params tables grouping ('Required ('Null ty))
393+ -> SortExpression params tables grouping
394+deriving instance Show (SortExpression params tables grouping)
395+
396+renderSortExpression :: SortExpression params tables grouping -> ByteString
397+renderSortExpression = \case
398+ Asc expression -> renderExpression expression <+> "ASC"
399+ Desc expression -> renderExpression expression <+> "DESC"
400+ AscNullsFirst expression -> renderExpression expression
401+ <+> "ASC NULLS FIRST"
402+ DescNullsFirst expression -> renderExpression expression
403+ <+> "DESC NULLS FIRST"
404+ AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"
405+ DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"
squeal-postgresql/test/DocTest.hs+3−1
@@ -6,5 +6,7 @@ main :: IO ()
6main = doctest
6main = doctest
7 [ "-isrc"
7 [ "-isrc"
8 , "src/Squeal/PostgreSQL/Binary.hs"
8 , "src/Squeal/PostgreSQL/Binary.hs"
9− , "src/Squeal/PostgreSQL/Statement.hs"
9+ , "src/Squeal/PostgreSQL/Definition.hs"
10+ , "src/Squeal/PostgreSQL/Manipulation.hs"
11+ , "src/Squeal/PostgreSQL/Query.hs"
10 ]
12 ]
squeal-postgresql/test/Squeal/PostgreSQL/DefinitionSpec.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , MagicHash
4+ , OverloadedLabels
5+ , OverloadedStrings
6+ , TypeApplications
7+ , TypeOperators
8+#-}
9+
10+module Squeal.PostgreSQL.DefinitionSpec where
11+
12+import Control.Category ((>>>))
13+import Data.Function
14+import Generics.SOP hiding (from)
15+import Test.Hspec
16+
17+import Squeal.PostgreSQL
18+
19+spec :: Spec
20+spec = do
21+ let
22+ definition `definitionRenders` str =
23+ renderDefinition definition `shouldBe` str
24+ it "should render CREATE TABLE statements" $ do
25+ createTable #table1
26+ ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)
27+ [primaryKey (Column #col1 :* Column #col2 :* Nil)]
28+ `definitionRenders`
29+ "CREATE TABLE table1\
30+ \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\
31+ \ PRIMARY KEY (col1, col2));"
32+ createTable #table2
33+ ( serial `As` #col1 :*
34+ text `As` #col2 :*
35+ (int8 & notNull & default_ 8) `As` #col3 :* Nil )
36+ [check (#col3 >* 0)]
37+ `definitionRenders`
38+ "CREATE TABLE table2\
39+ \ (col1 serial,\
40+ \ col2 text,\
41+ \ col3 int8 NOT NULL DEFAULT 8,\
42+ \ CHECK ((col3 > 0)));"
43+ let
44+ statement :: Definition '[]
45+ '[ "users" :::
46+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
47+ , "username" ::: 'Required ('NotNull 'PGtext)
48+ ]
49+ , "emails" :::
50+ '[ "id" ::: 'Optional ('NotNull 'PGint4)
51+ , "userid" ::: 'Required ('NotNull 'PGint4)
52+ , "email" ::: 'Required ('NotNull 'PGtext)
53+ ]
54+ ]
55+ statement =
56+ createTable #users
57+ (serial `As` #id :* (text & notNull) `As` #username :* Nil)
58+ [primaryKey (Column #id :* Nil)]
59+ >>>
60+ createTable #emails
61+ ( serial `As` #id :*
62+ (integer & notNull) `As` #userid :*
63+ (text & notNull) `As` #email :* Nil )
64+ [ primaryKey (Column #id :* Nil)
65+ , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
66+ OnDeleteCascade OnUpdateRestrict
67+ , unique (Column #email :* Nil)
68+ , check (#email /=* "")
69+ ]
70+ statement `definitionRenders`
71+ "CREATE TABLE users\
72+ \ (id serial, username text NOT NULL,\
73+ \ PRIMARY KEY (id));\
74+ \ \
75+ \CREATE TABLE emails\
76+ \ (id serial,\
77+ \ userid integer NOT NULL,\
78+ \ email text NOT NULL,\
79+ \ PRIMARY KEY (id),\
80+ \ FOREIGN KEY (userid) REFERENCES users (id)\
81+ \ ON DELETE CASCADE ON UPDATE RESTRICT,\
82+ \ UNIQUE (email),\
83+ \ CHECK ((email <> E'')));"
84+ it "should render DROP TABLE statements" $ do
85+ let
86+ statement :: Definition Tables '[]
87+ statement = dropTable #table1
88+ statement `definitionRenders` "DROP TABLE table1;"
89+
90+type Columns =
91+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
92+ , "col2" ::: 'Required ('NotNull 'PGint4)
93+ ]
94+type Tables = '[ "table1" ::: Columns ]
95+type SumAndCol1 =
96+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
97+ , "col1" ::: 'Required ('NotNull 'PGint4)
98+ ]
99+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
100+type StudentsTable = '["students" ::: StudentsColumns]
101+type OrderColumns =
102+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)
103+ , "orderVal" ::: 'Required ('NotNull 'PGtext)
104+ , "customerID" ::: 'Required ('NotNull 'PGint4)
105+ , "shipperID" ::: 'Required ('NotNull 'PGint4)
106+ ]
107+type CustomerColumns =
108+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)
109+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
110+ ]
111+type ShipperColumns =
112+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
113+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
114+ ]
115+type JoinTables =
116+ '[ "orders" ::: OrderColumns
117+ , "customers" ::: CustomerColumns
118+ , "shippers" ::: ShipperColumns
119+ ]
120+type ValueColumns =
121+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
122+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
123+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
124+ ]
squeal-postgresql/test/Squeal/PostgreSQL/ManipulationSpec.hsnew file+128
@@ -0,0 +1,128 @@
1+{-# LANGUAGE
2+ DataKinds
3+ , MagicHash
4+ , OverloadedLabels
5+ , OverloadedStrings
6+ , TypeApplications
7+ , TypeOperators
8+#-}
9+
10+module Squeal.PostgreSQL.ManipulationSpec where
11+
12+import Generics.SOP hiding (from)
13+import Test.Hspec
14+
15+import Squeal.PostgreSQL
16+
17+spec :: Spec
18+spec = do
19+ let
20+ manipulation `manipulationRenders` str =
21+ renderManipulation manipulation `shouldBe` str
22+ it "correctly renders returning INSERTs" $ do
23+ let
24+ statement :: Manipulation Tables '[] SumAndCol1
25+ statement =
26+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
27+ Conflict
28+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
29+ statement `manipulationRenders`
30+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
31+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
32+ it "correctly renders simple UPDATEs" $ do
33+ let
34+ statement :: Manipulation Tables '[] '[]
35+ statement =
36+ update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
37+ (#col1 /=* #col2) (Returning Nil)
38+ statement `manipulationRenders`
39+ "UPDATE table1 SET col1 = 2\
40+ \ WHERE (col1 <> col2);"
41+ it "correctly renders returning UPDATEs" $ do
42+ let
43+ statement :: Manipulation Tables '[] SumAndCol1
44+ statement =
45+ update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
46+ (#col1 /=* #col2)
47+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
48+ statement `manipulationRenders`
49+ "UPDATE table1 SET col1 = 2\
50+ \ WHERE (col1 <> col2)\
51+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
52+ it "correctly renders upsert INSERTs" $ do
53+ let
54+ statement :: Manipulation Tables '[] '[]
55+ statement =
56+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
57+ (OnConflictDoUpdate
58+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)
59+ (Returning Nil)
60+ statement `manipulationRenders`
61+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
62+ \ ON CONFLICT DO UPDATE\
63+ \ SET col1 = 2;"
64+ it "correctly renders returning upsert INSERTs" $ do
65+ let
66+ statement :: Manipulation Tables '[] SumAndCol1
67+ statement =
68+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
69+ (OnConflictDoUpdate
70+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
71+ (Just (#col1 /=* #col2)))
72+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
73+ statement `manipulationRenders`
74+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
75+ \ ON CONFLICT DO UPDATE\
76+ \ SET col1 = 2\
77+ \ WHERE (col1 <> col2)\
78+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
79+ it "correctly renders DELETEs" $ do
80+ let
81+ statement :: Manipulation Tables '[] '[]
82+ statement = deleteFrom #table1 (#col1 ==* #col2)
83+ statement `manipulationRenders`
84+ "DELETE FROM table1 WHERE (col1 = col2);"
85+ it "should be safe against SQL injection in literal text" $ do
86+ let
87+ statement :: Manipulation StudentsTable '[] '[]
88+ statement = insertInto #students
89+ (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])
90+ Conflict (Returning Nil)
91+ statement `manipulationRenders`
92+ "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
93+
94+type Columns =
95+ '[ "col1" ::: 'Required ('NotNull 'PGint4)
96+ , "col2" ::: 'Required ('NotNull 'PGint4)
97+ ]
98+type Tables = '[ "table1" ::: Columns ]
99+type SumAndCol1 =
100+ '[ "sum" ::: 'Required ('NotNull 'PGint4)
101+ , "col1" ::: 'Required ('NotNull 'PGint4)
102+ ]
103+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
104+type StudentsTable = '["students" ::: StudentsColumns]
105+type OrderColumns =
106+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)
107+ , "orderVal" ::: 'Required ('NotNull 'PGtext)
108+ , "customerID" ::: 'Required ('NotNull 'PGint4)
109+ , "shipperID" ::: 'Required ('NotNull 'PGint4)
110+ ]
111+type CustomerColumns =
112+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)
113+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
114+ ]
115+type ShipperColumns =
116+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
117+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
118+ ]
119+type JoinTables =
120+ '[ "orders" ::: OrderColumns
121+ , "customers" ::: CustomerColumns
122+ , "shippers" ::: ShipperColumns
123+ ]
124+type ValueColumns =
125+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
126+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
127+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)
128+ ]
squeal-postgresql/test/Squeal/PostgreSQL/StatementSpec.hs → squeal-postgresql/test/Squeal/PostgreSQL/QuerySpec.hsrenamed+4−153
@@ -7,24 +7,19 @@
7 , TypeOperators
7 , TypeOperators
8#-}
8#-}
9
9
10−module Squeal.PostgreSQL.StatementSpec where
10+module Squeal.PostgreSQL.QuerySpec where
11
11
12−import Control.Category ((>>>))
13import Data.Function
12import Data.Function
14import Generics.SOP hiding (from)
13import Generics.SOP hiding (from)
15import Test.Hspec
14import Test.Hspec
16
15
17−import Squeal.PostgreSQL.Statement
16+import Squeal.PostgreSQL
18−import Squeal.PostgreSQL.Schema
19
17
20spec :: Spec
18spec :: Spec
21spec = do
19spec = do
22 let
20 let
23− qry `queryRenders` str = queryStatement qry `manipulationRenders` str
21+ qry `queryRenders` str =
24− definition `definitionRenders` str =
25− renderDefinition definition `shouldBe` str
26− manipulation `manipulationRenders` str =
27− renderManipulation manipulation `shouldBe` str
22+ renderManipulation (queryStatement qry) `shouldBe` str
28 it "correctly renders a simple SELECT query" $ do
23 it "correctly renders a simple SELECT query" $ do
29 let
24 let
30 statement :: Query Tables '[] SumAndCol1
25 statement :: Query Tables '[] SumAndCol1
@@ -97,85 +92,6 @@ spec = do
97 \ FROM table1 AS table1\
92 \ FROM table1 AS table1\
98 \ GROUP BY col1\
93 \ GROUP BY col1\
99 \ HAVING ((col1 + sum(col2)) > 1);"
94 \ HAVING ((col1 + sum(col2)) > 1);"
100− it "correctly renders simple INSERTs" $ do
101− let
102− statement :: Manipulation Tables '[] '[]
103− statement =
104− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
105− Conflict (Returning Nil)
106− statement `manipulationRenders`
107− "INSERT INTO table1 (col1, col2) VALUES (2, 4);"
108− it "correctly renders returning INSERTs" $ do
109− let
110− statement :: Manipulation Tables '[] SumAndCol1
111− statement =
112− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
113− Conflict
114− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
115− statement `manipulationRenders`
116− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
117− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
118− it "correctly renders simple UPDATEs" $ do
119− let
120− statement :: Manipulation Tables '[] '[]
121− statement =
122− update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
123− (#col1 /=* #col2) (Returning Nil)
124− statement `manipulationRenders`
125− "UPDATE table1 SET col1 = 2\
126− \ WHERE (col1 <> col2);"
127− it "correctly renders returning UPDATEs" $ do
128− let
129− statement :: Manipulation Tables '[] SumAndCol1
130− statement =
131− update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
132− (#col1 /=* #col2)
133− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
134− statement `manipulationRenders`
135− "UPDATE table1 SET col1 = 2\
136− \ WHERE (col1 <> col2)\
137− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
138− it "correctly renders upsert INSERTs" $ do
139− let
140− statement :: Manipulation Tables '[] '[]
141− statement =
142− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
143− (OnConflictDoUpdate
144− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)
145− (Returning Nil)
146− statement `manipulationRenders`
147− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
148− \ ON CONFLICT DO UPDATE\
149− \ SET col1 = 2;"
150− it "correctly renders returning upsert INSERTs" $ do
151− let
152− statement :: Manipulation Tables '[] SumAndCol1
153− statement =
154− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
155− (OnConflictDoUpdate
156− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
157− (Just (#col1 /=* #col2)))
158− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
159− statement `manipulationRenders`
160− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
161− \ ON CONFLICT DO UPDATE\
162− \ SET col1 = 2\
163− \ WHERE (col1 <> col2)\
164− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
165− it "correctly renders DELETEs" $ do
166− let
167− statement :: Manipulation Tables '[] '[]
168− statement = deleteFrom #table1 (#col1 ==* #col2)
169− statement `manipulationRenders`
170− "DELETE FROM table1 WHERE (col1 = col2);"
171− it "should be safe against SQL injection in literal text" $ do
172− let
173− statement :: Manipulation StudentsTable '[] '[]
174− statement = insertInto #students
175− (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])
176− Conflict (Returning Nil)
177− statement `manipulationRenders`
178− "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
179 describe "JOINs" $ do
95 describe "JOINs" $ do
180 it "should render CROSS JOINs" $ do
96 it "should render CROSS JOINs" $ do
181 let
97 let
@@ -227,71 +143,6 @@ spec = do
227 "SELECT orders1.*\
143 "SELECT orders1.*\
228 \ FROM orders AS orders1\
144 \ FROM orders AS orders1\
229 \ CROSS JOIN orders AS orders2;"
145 \ CROSS JOIN orders AS orders2;"
230− it "should render CREATE TABLE statements" $ do
231− createTable #table1
232− ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)
233− [primaryKey (Column #col1 :* Column #col2 :* Nil)]
234− `definitionRenders`
235− "CREATE TABLE table1\
236− \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\
237− \ PRIMARY KEY (col1, col2));"
238− createTable #table2
239− ( serial `As` #col1 :*
240− text `As` #col2 :*
241− (int8 & notNull & default_ 8) `As` #col3 :* Nil )
242− [check (#col3 >* 0)]
243− `definitionRenders`
244− "CREATE TABLE table2\
245− \ (col1 serial,\
246− \ col2 text,\
247− \ col3 int8 NOT NULL DEFAULT 8,\
248− \ CHECK ((col3 > 0)));"
249− let
250− statement :: Definition '[]
251− '[ "users" :::
252− '[ "id" ::: 'Optional ('NotNull 'PGint4)
253− , "username" ::: 'Required ('NotNull 'PGtext)
254− ]
255− , "emails" :::
256− '[ "id" ::: 'Optional ('NotNull 'PGint4)
257− , "userid" ::: 'Required ('NotNull 'PGint4)
258− , "email" ::: 'Required ('NotNull 'PGtext)
259− ]
260− ]
261− statement =
262− createTable #users
263− (serial `As` #id :* (text & notNull) `As` #username :* Nil)
264− [primaryKey (Column #id :* Nil)]
265− >>>
266− createTable #emails
267− ( serial `As` #id :*
268− (integer & notNull) `As` #userid :*
269− (text & notNull) `As` #email :* Nil )
270− [ primaryKey (Column #id :* Nil)
271− , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
272− OnDeleteCascade OnUpdateRestrict
273− , unique (Column #email :* Nil)
274− , check (#email /=* "")
275− ]
276− statement `definitionRenders`
277− "CREATE TABLE users\
278− \ (id serial, username text NOT NULL,\
279− \ PRIMARY KEY (id));\
280− \ \
281− \CREATE TABLE emails\
282− \ (id serial,\
283− \ userid integer NOT NULL,\
284− \ email text NOT NULL,\
285− \ PRIMARY KEY (id),\
286− \ FOREIGN KEY (userid) REFERENCES users (id)\
287− \ ON DELETE CASCADE ON UPDATE RESTRICT,\
288− \ UNIQUE (email),\
289− \ CHECK ((email <> E'')));"
290− it "should render DROP TABLE statements" $ do
291− let
292− statement :: Definition Tables '[]
293− statement = dropTable #table1
294− statement `definitionRenders` "DROP TABLE table1;"
295
146
296type Columns =
147type Columns =
297 '[ "col1" ::: 'Required ('NotNull 'PGint4)
148 '[ "col1" ::: 'Required ('NotNull 'PGint4)