git.iko.soy/squeal
on dev help sign in
fix some tests
commit56462b3b3ebfc19b7436d9d0c77f5136f7346139 authorEitan Chatav <eitan.chatav@gmail.com> dateSun 24 Dec 2017, 14:28 (9 years ago) parent2cc1ff1
5 files changed+82−93
compare with dev
unifiedsplit
squeal-postgresql/squeal-postgresql.cabal−16 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+20−21 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+51−51 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−1 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+10−4
squeal-postgresql/squeal-postgresql.cabal−16
@@ -51,22 +51,6 @@ library
5151 , transformers-base >= 0.4.4 && < 1
5252 , uuid >= 1.3.13 && < 2
5353
54−test-suite squeal-postgresql-spec
55− default-language: Haskell2010
56− type: exitcode-stdio-1.0
57− hs-source-dirs: test
58− ghc-options: -Wall
59− main-is: Spec.hs
60− other-modules:
61− Squeal.PostgreSQL.DefinitionSpec
62− Squeal.PostgreSQL.ManipulationSpec
63− Squeal.PostgreSQL.QuerySpec
64− build-depends:
65− base >= 4.10.0.0 && < 5
66− , generics-sop >= 0.3.1.0 && < 1
67− , hspec >= 2.4.4 && < 3
68− , squeal-postgresql
69−
7054test-suite squeal-postgresql-doctest
7155 default-language: Haskell2010
7256 type: exitcode-stdio-1.0
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+20−21
@@ -118,13 +118,13 @@ instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
118118-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
119119-- not define instances of `ToColumnParam`, just use the provided instances.
120120class ToColumnParam (x :: Type) (ty :: NullityType) where
121− -- | >>> toColumnParam @Int16 @'( '[], ('NotNull 'PGint2)) 0
121+ -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0
122122 -- K (Just "\NUL\NUL")
123123 --
124− -- >>> toColumnParam @(Maybe Int16) @'( '[], ('Null 'PGint2)) (Just 0)
124+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)
125125 -- K (Just "\NUL\NUL")
126126 --
127− -- >>> toColumnParam @(Maybe Int16) @'( '[], ('Null 'PGint2)) Nothing
127+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing
128128 -- K Nothing
129129 toColumnParam :: x -> K (Maybe Strict.ByteString) ty
130130instance ToParam x pg => ToColumnParam x ('NotNull pg) where
@@ -137,14 +137,14 @@ instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where
137137-- not define instances of `ToParams`. Instead define `Generic` instances
138138-- which in turn provide `ToParams` instances.
139139class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
140− -- | >>> type PGparams = '[ 'Required ('NotNull 'PGbool), 'Required ('Null 'PGint2)]
141− -- >>> toParams @(Bool, Maybe Int16) @PGparams (False, Just 0)
140+ -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
141+ -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)
142142 -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)
143143 --
144144 -- >>> :set -XDeriveGeneric
145− -- >>> data Hparams = Hparams { col1 :: Bool, col2 :: Maybe Int16} deriving GHC.Generic
146− -- >>> instance Generic Hparams
147− -- >>> toParams @Hparams @PGparams (Hparams False (Just 0))
145+ -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic
146+ -- >>> instance Generic Tuple
147+ -- >>> toParams @Tuple @Params (Tuple False (Just 0))
148148 -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)
149149 toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
150150instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
@@ -196,10 +196,10 @@ class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where
196196 -- | >>> :set -XTypeOperators -XOverloadedStrings
197197 -- >>> newtype Id = Id { getId :: Int16 } deriving Show
198198 -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
199− -- >>> fromColumnValue @("col" ::: 'Required ('NotNull 'PGint2)) @Id (K (Just "\NUL\SOH"))
199+ -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH"))
200200 -- Id {getId = 1}
201201 --
202− -- >>> fromColumnValue @("col" ::: 'Required ('Null 'PGint2)) @(Maybe Id) (K (Just "\NUL\SOH"))
202+ -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))
203203 -- Just (Id {getId = 1})
204204 fromColumnValue :: K (Maybe Strict.ByteString) colty -> y
205205instance FromValue pg y
@@ -230,14 +230,14 @@ instance FromValue pg y
230230class SListI results => FromRow (results :: RelationType) y where
231231 -- | >>> :set -XOverloadedStrings
232232 -- >>> import Data.Text
233− -- >>> newtype Id = Id { getId :: Int16 } deriving Show
234− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
235− -- >>> data Hrow = Hrow { userId :: Id, userName :: Maybe Text } deriving (Show, GHC.Generic)
236− -- >>> instance Generic Hrow
237− -- >>> instance HasDatatypeInfo Hrow
238− -- >>> type PGrow = '["userId" ::: 'Required ('NotNull 'PGint2), "userName" ::: 'Required ('Null 'PGtext)]
239− -- >>> fromRow @PGrow @Hrow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
240− -- Hrow {userId = Id {getId = 1}, userName = Just "bloodninja"}
233+ -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show
234+ -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue
235+ -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)
236+ -- >>> instance Generic UserRow
237+ -- >>> instance HasDatatypeInfo UserRow
238+ -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]
239+ -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
240+ -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}
241241 fromRow :: NP (K (Maybe Strict.ByteString)) results -> y
242242instance
243243 ( SListI results
@@ -252,11 +252,10 @@ instance
252252-- `toParams` or decoding a single value with `fromRow`.
253253--
254254-- >>> import Data.Text
255−-- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))
255+-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))
256256-- K (Just "foo") :* Nil
257257--
258−-- >>> type PGShortRow = '["fromOnly" ::: 'Required ('Null 'PGtext)]
259−-- >>> fromRow @PGShortRow @(Only (Maybe Text)) (K (Just "bar") :* Nil)
258+-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)
260259-- Only {fromOnly = Just "bar"}
261260newtype Only x = Only { fromOnly :: x }
262261 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+51−51
@@ -102,7 +102,7 @@ CREATE statements
102102-- >>> :set -XOverloadedLabels
103103-- >>> :{
104104-- renderDefinition $
105−-- createTable #tab (int `As` #a :* real `As` #b :* Nil) []
105+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil
106106-- :}
107107-- "CREATE TABLE tab (a int, b real);"
108108createTable
@@ -122,7 +122,10 @@ createTable table columns constraints = UnsafeDefinition $
122122 "CREATE TABLE" <+> renderAlias table
123123 <+> parenthesized
124124 ( renderCommaSeparated renderColumnDef columns
125− <> renderCommaSeparated renderConstraint constraints )
125+ <> ( case constraints of
126+ Nil -> ""
127+ _ -> ", " <>
128+ renderCommaSeparated renderConstraint constraints ) )
126129 <> ";"
127130 where
128131 renderColumnDef :: Aliased TypeExpression x -> ByteString
@@ -163,9 +166,9 @@ newtype TableConstraintExpression
163166-- createTable #tab
164167-- ( (int & notNull) `As` #a :*
165168-- (int & notNull) `As` #b :* Nil )
166−-- [ check (#a .> #b) ]
169+-- ( check (#a .> #b) `As` #inequality :* Nil )
167170-- :}
168−-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CHECK ((a > b)));"
171+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CONSTRAINT inequality CHECK ((a > b)));"
169172check
170173 :: Condition '[table ::: columns] 'Ungrouped '[]
171174 -- ^ condition to check
@@ -181,14 +184,14 @@ check condition = UnsafeTableConstraintExpression $
181184-- createTable #tab
182185-- ( int `As` #a :*
183186-- int `As` #b :* Nil )
184−-- [ unique (Column #a :* Column #b :* Nil) ]
187+-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )
185188-- :}
186−-- "CREATE TABLE tab (a int, b int, UNIQUE (a, b));"
189+-- "CREATE TABLE tab (a int, b int, CONSTRAINT uq_a_b UNIQUE (a, b));"
187190unique
188191 :: SOP.SListI subcolumns
189192 => NP (Column columns) subcolumns
190193 -- ^ unique column or group of columns
191− -> TableConstraintExpression schema columns ( 'Uniques (Aliases subcolumns))
194+ -> TableConstraintExpression schema columns ('Unique (Aliases subcolumns))
192195unique columns = UnsafeTableConstraintExpression $
193196 "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
194197
@@ -201,9 +204,9 @@ unique columns = UnsafeTableConstraintExpression $
201204-- createTable #tab
202205-- ( serial `As` #id :*
203206-- (text & notNull) `As` #name :* Nil )
204−-- [ primaryKey (Column #id :* Nil) ]
207+-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )
205208-- :}
206−-- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"
209+-- "CREATE TABLE tab (id serial, name text NOT NULL, CONSTRAINT pk_id PRIMARY KEY (id));"
207210primaryKey
208211 :: (SOP.SListI subcolumns, AllNotNull subcolumns)
209212 => NP (Column columns) subcolumns
@@ -218,33 +221,41 @@ primaryKey columns = UnsafeTableConstraintExpression $
218221-- between two related tables.
219222--
220223-- >>> :{
221−-- let
222−-- definition :: Definition '[]
223−-- '[ "users" :::
224−-- '[ "id" ::: 'Optional ('NotNull 'PGint4)
225−-- , "username" ::: 'Required ('NotNull 'PGtext)
224+-- type Schema =
225+-- '[ "users" :::
226+-- '[ "pk_id" ::: 'PrimaryKey '["id"] ] :=>
227+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
228+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
226229-- ]
227−-- , "emails" :::
228−-- '[ "id" ::: 'Optional ('NotNull 'PGint4)
229−-- , "userid" ::: 'Required ('NotNull 'PGint4)
230−-- , "email" ::: 'Required ('NotNull 'PGtext)
230+-- , "emails" :::
231+-- '[ "pk_id" ::: 'PrimaryKey '["id"]
232+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
233+-- ] :=>
234+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
235+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
236+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
231237-- ]
232−-- ]
233−-- definition =
238+-- ]
239+-- :}
240+--
241+-- :{
242+-- let
243+-- setup :: Definition '[] Schema
244+-- setup =
234245-- createTable #users
235−-- (serial `As` #id :* (text & notNull) `As` #username :* Nil)
236−-- [primaryKey (Column #id :* Nil)] >>>
246+-- ( #id serial :*
247+-- #name (text & notNull) :* Nil )
248+-- ( #pk_id (primaryKey (Column #id :* Nil)) :* Nil ) >>>
237249-- createTable #emails
238−-- ( serial `As` #id :*
239−-- (integer & notNull) `As` #userid :*
240−-- (text & notNull) `As` #email :* Nil )
241−-- [ primaryKey (Column #id :* Nil)
242−-- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
243−-- OnDeleteCascade OnUpdateRestrict
244−-- ]
245−-- in renderDefinition definition
250+-- ( #id serial :*
251+-- #user_id (int & notNull) :*
252+-- #email text :* Nil )
253+-- ( #pk_id (primaryKey (Column #id :* Nil)) :*
254+-- #fk_user_id (foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
255+-- OnDeleteCascade OnUpdateCascade) :* Nil )
256+-- in renderDefinition setup
246257-- :}
247−-- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"
258+-- "CREATE TABLE users (id serial, username text NOT NULL, CONSTRAINT pk_id PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, CONSTRAINT pk_id PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"
248259foreignKey
249260 :: ( HasTable tab (UnconstrainSchema schema) refcolumns
250261 , SameTypes subcolumns refsubcolumns
@@ -353,33 +364,22 @@ alterTableRename table0 table1 = UnsafeDefinition $
353364 "ALTER TABLE" <+> renderAlias table0
354365 <+> "RENAME TO" <+> renderAlias table1 <> ";"
355366
356−-- | An `alterTableAddConstraint` adds a table constraint.
367+-- | An `addConstraint` adds a table constraint.
357368--
358369-- >>> :{
359370-- let
360371-- definition :: Definition
361−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
362−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
363−-- definition = alterTableAddConstraint #tab (check (#col .> 0))
372+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
373+-- '["tab" ::: '["positive" ::: Check ] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
374+-- definition = alterTable #tab (addConstraint #positive (check (#col .> 0)))
364375-- in renderDefinition definition
365376-- :}
366−-- "ALTER TABLE tab ADD CHECK ((col > 0));"
367−-- alterTableAddConstraint
368−-- :: (HasTable table schema columns, (table ::: table0) `In` schema)
369−-- => Alias table -- ^ table to constrain
370−-- -> TableConstraintExpression schema columns constraint -- ^ what constraint to add
371−-- -> Definition schema (Alter table schema (AddConstraint constraint table0))
372−-- alterTableAddConstraint table constraint = UnsafeDefinition $
373−-- "ALTER TABLE" <+> renderAlias table
374−-- <+> "ADD" <+> renderTableConstraintExpression constraint <> ";"
375−
377+-- "ALTER TABLE tab ADD CONSTRAINT positive CHECK ((col > 0));"
376378addConstraint
377379 :: KnownSymbol constraintName
378380 => Alias constraintName
379− -> TableConstraintExpression schema (UnconstrainColumns columns) constraint
380− -> AlterTable schema
381− (constraints :=> columns)
382− (Create constraintName constraint constraints :=> columns)
381+ -> TableConstraintExpression schema (UnconstrainColumns (UnconstrainTable table)) constraint
382+ -> AlterTable schema table (AddConstraint constraintName constraint table)
383383addConstraint constraintName constraint = UnsafeAlterTable $
384384 "ADD" <+> "CONSTRAINT" <+> renderAlias constraintName
385385 <+> renderTableConstraintExpression constraint
@@ -421,7 +421,7 @@ addColumnDefault
421421 :: KnownSymbol column
422422 => Alias column -- ^ column to add
423423 -> TypeExpression ('Def :=> ty) -- ^ type of the new column
424− -> AlterTable schema table (Add column ('Def :=> ty) table)
424+ -> AlterTable schema table (AddColumn column ('Def :=> ty) table)
425425addColumnDefault column ty = UnsafeAlterTable $
426426 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
427427
@@ -443,7 +443,7 @@ addColumnNull
443443 :: KnownSymbol column
444444 => Alias column -- ^ column to add
445445 -> TypeExpression ('NoDef :=> 'Null ty) -- ^ type of the new column
446− -> AlterTable schema table (Add column ('NoDef :=> 'Null ty) table)
446+ -> AlterTable schema table (AddColumn column ('NoDef :=> 'Null ty) table)
447447addColumnNull column ty = UnsafeAlterTable $
448448 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
449449
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−1
@@ -120,7 +120,7 @@ To specify the schema you wish to connect with, use type application.
120120
121121>>> :set -XDataKinds
122122>>> :set -XTypeOperators
123−>>> type Schema = '["tab" ::: '["col" ::: 'Required ('Null 'PGint2)]]
123+>>> type Schema = '["tab" ::: Unconstraint :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]]
124124>>> :set -XTypeApplications
125125>>> :set -XOverloadedStrings
126126>>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+10−4
@@ -67,7 +67,8 @@ module Squeal.PostgreSQL.Schema
6767 , NullifyTables
6868 , Join
6969 , Create
70− , Add
70+ , AddColumn
71+ , AddConstraint
7172 , Drop
7273 , Alter
7374 , Rename
@@ -76,6 +77,7 @@ module Squeal.PostgreSQL.Schema
7677 , SameFields
7778 -- * PostgreSQL Constraints
7879 , (:=>)
80+ , Unconstraint
7981 , UnconstrainColumn
8082 , UnconstrainColumns
8183 , UnconstrainTable
@@ -310,8 +312,11 @@ type family Create alias x xs where
310312 Create alias x '[] = '[alias ::: x]
311313 Create alias y (x ': xs) = x ': Create alias y xs
312314
313−type family Add alias x y where
314− Add alias x (constraints :=> xs) = constraints :=> Create alias x xs
315+type family AddColumn alias x y where
316+ AddColumn alias x (constraints :=> xs) = constraints :=> Create alias x xs
317+
318+type family AddConstraint alias x y where
319+ AddConstraint alias x (constraints :=> xs) = Create alias x constraints :=> xs
315320
316321-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
317322-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
@@ -377,11 +382,12 @@ data ColumnConstraint
377382
378383data TableConstraint
379384 = Check
380− | Uniques [Symbol]
385+ | Unique [Symbol]
381386 | PrimaryKey [Symbol]
382387 | ForeignKey [Symbol] Symbol [Symbol]
383388
384389type TableConstraints = [(Symbol,TableConstraint)]
390+type Unconstraint = ('[] :: TableConstraints)
385391
386392type family Aliases xs where
387393 Aliases '[] = '[]