56462b3 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

fix some tests

56462b3Eitan Chatav9 years ago

squeal-postgresql/squeal-postgresql.cabal−16

compare with dev

unifiedsplit

@@ -51,22 +51,6 @@ library

51 , transformers-base >= 0.4.4 && < 1

52 , uuid >= 1.3.13 && < 2

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−

70test-suite squeal-postgresql-doctest

54test-suite squeal-postgresql-doctest

71 default-language: Haskell2010

55 default-language: Haskell2010

72 type: exitcode-stdio-1.0

56 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

118-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should

119-- not define instances of `ToColumnParam`, just use the provided instances.

120class ToColumnParam (x :: Type) (ty :: NullityType) where

121− -- | >>> toColumnParam @Int16 @'( '[], ('NotNull 'PGint2)) 0

121+ -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0

122 -- K (Just "\NUL\NUL")

123 --

124− -- >>> toColumnParam @(Maybe Int16) @'( '[], ('Null 'PGint2)) (Just 0)

124+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)

125 -- K (Just "\NUL\NUL")

126 --

127− -- >>> toColumnParam @(Maybe Int16) @'( '[], ('Null 'PGint2)) Nothing

127+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing

128 -- K Nothing

129 toColumnParam :: x -> K (Maybe Strict.ByteString) ty

130instance ToParam x pg => ToColumnParam x ('NotNull pg) where

@@ -137,14 +137,14 @@ instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where

137-- not define instances of `ToParams`. Instead define `Generic` instances

138-- which in turn provide `ToParams` instances.

139class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

140− -- | >>> type PGparams = '[ 'Required ('NotNull 'PGbool), 'Required ('Null 'PGint2)]

140+ -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]

141− -- >>> toParams @(Bool, Maybe Int16) @PGparams (False, Just 0)

141+ -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)

142 -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)

143 --

144 -- >>> :set -XDeriveGeneric

145− -- >>> data Hparams = Hparams { col1 :: Bool, col2 :: Maybe Int16} deriving GHC.Generic

145+ -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic

146− -- >>> instance Generic Hparams

146+ -- >>> instance Generic Tuple

147− -- >>> toParams @Hparams @PGparams (Hparams False (Just 0))

147+ -- >>> toParams @Tuple @Params (Tuple False (Just 0))

148 -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)

149 toParams :: x -> NP (K (Maybe Strict.ByteString)) tys

150instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)

@@ -196,10 +196,10 @@ class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where

196 -- | >>> :set -XTypeOperators -XOverloadedStrings

197 -- >>> newtype Id = Id { getId :: Int16 } deriving Show

198 -- >>> 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"))

200 -- Id {getId = 1}

201 --

202− -- >>> fromColumnValue @("col" ::: 'Required ('Null 'PGint2)) @(Maybe Id) (K (Just "\NUL\SOH"))

202+ -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))

203 -- Just (Id {getId = 1})

204 fromColumnValue :: K (Maybe Strict.ByteString) colty -> y

205instance FromValue pg y

@@ -230,14 +230,14 @@ instance FromValue pg y

230class SListI results => FromRow (results :: RelationType) y where

231 -- | >>> :set -XOverloadedStrings

232 -- >>> import Data.Text

233− -- >>> newtype Id = Id { getId :: Int16 } deriving Show

233+ -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show

234− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

234+ -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue

235− -- >>> data Hrow = Hrow { userId :: Id, userName :: Maybe Text } deriving (Show, GHC.Generic)

235+ -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)

236− -- >>> instance Generic Hrow

236+ -- >>> instance Generic UserRow

237− -- >>> instance HasDatatypeInfo Hrow

237+ -- >>> instance HasDatatypeInfo UserRow

238− -- >>> type PGrow = '["userId" ::: 'Required ('NotNull 'PGint2), "userName" ::: 'Required ('Null 'PGtext)]

238+ -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]

239− -- >>> fromRow @PGrow @Hrow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)

239+ -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)

240− -- Hrow {userId = Id {getId = 1}, userName = Just "bloodninja"}

240+ -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}

241 fromRow :: NP (K (Maybe Strict.ByteString)) results -> y

242instance

243 ( SListI results

@@ -252,11 +252,10 @@ instance

252-- `toParams` or decoding a single value with `fromRow`.

253--

254-- >>> import Data.Text

255−-- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))

255+-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))

256-- K (Just "foo") :* Nil

257--

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)

260-- Only {fromOnly = Just "bar"}

259-- Only {fromOnly = Just "bar"}

261newtype Only x = Only { fromOnly :: x }

260newtype Only x = Only { fromOnly :: x }

262 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)

261 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

102-- >>> :set -XOverloadedLabels

103-- >>> :{

104-- renderDefinition $

105−-- createTable #tab (int `As` #a :* real `As` #b :* Nil) []

105+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil

106-- :}

107-- "CREATE TABLE tab (a int, b real);"

108createTable

@@ -122,7 +122,10 @@ createTable table columns constraints = UnsafeDefinition $

122 "CREATE TABLE" <+> renderAlias table

123 <+> parenthesized

124 ( renderCommaSeparated renderColumnDef columns

125+ <> ( case constraints of

126+ Nil -> ""

127+ _ -> ", " <>

125− <> renderCommaSeparated renderConstraint constraints )

128+ renderCommaSeparated renderConstraint constraints ) )

126 <> ";"

129 <> ";"

127 where

130 where

128 renderColumnDef :: Aliased TypeExpression x -> ByteString

131 renderColumnDef :: Aliased TypeExpression x -> ByteString

@@ -163,9 +166,9 @@ newtype TableConstraintExpression

163-- createTable #tab

166-- createTable #tab

164-- ( (int & notNull) `As` #a :*

167-- ( (int & notNull) `As` #a :*

165-- (int & notNull) `As` #b :* Nil )

168-- (int & notNull) `As` #b :* Nil )

166−-- [ check (#a .> #b) ]

169+-- ( check (#a .> #b) `As` #inequality :* Nil )

167-- :}

170-- :}

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)));"

169check

172check

170 :: Condition '[table ::: columns] 'Ungrouped '[]

173 :: Condition '[table ::: columns] 'Ungrouped '[]

171 -- ^ condition to check

174 -- ^ condition to check

@@ -181,14 +184,14 @@ check condition = UnsafeTableConstraintExpression $

181-- createTable #tab

184-- createTable #tab

182-- ( int `As` #a :*

185-- ( int `As` #a :*

183-- int `As` #b :* Nil )

186-- int `As` #b :* Nil )

184−-- [ unique (Column #a :* Column #b :* Nil) ]

187+-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )

185-- :}

188-- :}

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));"

187unique

190unique

188 :: SOP.SListI subcolumns

191 :: SOP.SListI subcolumns

189 => NP (Column columns) subcolumns

192 => NP (Column columns) subcolumns

190 -- ^ unique column or group of columns

193 -- ^ unique column or group of columns

191− -> TableConstraintExpression schema columns ( 'Uniques (Aliases subcolumns))

194+ -> TableConstraintExpression schema columns ('Unique (Aliases subcolumns))

192unique columns = UnsafeTableConstraintExpression $

195unique columns = UnsafeTableConstraintExpression $

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

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

194

197

@@ -201,9 +204,9 @@ unique columns = UnsafeTableConstraintExpression $

201-- createTable #tab

204-- createTable #tab

202-- ( serial `As` #id :*

205-- ( serial `As` #id :*

203-- (text & notNull) `As` #name :* Nil )

206-- (text & notNull) `As` #name :* Nil )

204−-- [ primaryKey (Column #id :* Nil) ]

207+-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )

205-- :}

208-- :}

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));"

207primaryKey

210primaryKey

208 :: (SOP.SListI subcolumns, AllNotNull subcolumns)

211 :: (SOP.SListI subcolumns, AllNotNull subcolumns)

209 => NP (Column columns) subcolumns

212 => NP (Column columns) subcolumns

@@ -218,33 +221,41 @@ primaryKey columns = UnsafeTableConstraintExpression $

218-- between two related tables.

221-- between two related tables.

219--

222--

220-- >>> :{

223-- >>> :{

221−-- let

224+-- type Schema =

222−-- definition :: Definition '[]

223−-- '[ "users" :::

225+-- '[ "users" :::

226+-- '[ "pk_id" ::: 'PrimaryKey '["id"] ] :=>

224−-- '[ "id" ::: 'Optional ('NotNull 'PGint4)

227+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

225−-- , "username" ::: 'Required ('NotNull 'PGtext)

228+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

226-- ]

229-- ]

227−-- , "emails" :::

230+-- , "emails" :::

231+-- '[ "pk_id" ::: 'PrimaryKey '["id"]

232+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

233+-- ] :=>

228−-- '[ "id" ::: 'Optional ('NotNull 'PGint4)

234+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

229−-- , "userid" ::: 'Required ('NotNull 'PGint4)

235+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

230−-- , "email" ::: 'Required ('NotNull 'PGtext)

236+-- , "email" ::: 'NoDef :=> 'Null 'PGtext

231-- ]

237-- ]

232−-- ]

238+-- ]

233−-- definition =

239+-- :}

240+--

241+-- :{

242+-- let

243+-- setup :: Definition '[] Schema

244+-- setup =

234-- createTable #users

245-- createTable #users

246+-- ( #id serial :*

235−-- (serial `As` #id :* (text & notNull) `As` #username :* Nil)

247+-- #name (text & notNull) :* Nil )

236−-- [primaryKey (Column #id :* Nil)] >>>

248+-- ( #pk_id (primaryKey (Column #id :* Nil)) :* Nil ) >>>

237-- createTable #emails

249-- createTable #emails

238−-- ( serial `As` #id :*

250+-- ( #id serial :*

239−-- (integer & notNull) `As` #userid :*

251+-- #user_id (int & notNull) :*

240−-- (text & notNull) `As` #email :* Nil )

252+-- #email text :* Nil )

241−-- [ primaryKey (Column #id :* Nil)

253+-- ( #pk_id (primaryKey (Column #id :* Nil)) :*

242−-- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)

254+-- #fk_user_id (foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)

243−-- OnDeleteCascade OnUpdateRestrict

255+-- OnDeleteCascade OnUpdateCascade) :* Nil )

244−-- ]

245−-- in renderDefinition definition

256+-- in renderDefinition setup

246-- :}

257-- :}

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);"

248foreignKey

259foreignKey

249 :: ( HasTable tab (UnconstrainSchema schema) refcolumns

260 :: ( HasTable tab (UnconstrainSchema schema) refcolumns

250 , SameTypes subcolumns refsubcolumns

261 , SameTypes subcolumns refsubcolumns

@@ -353,33 +364,22 @@ alterTableRename table0 table1 = UnsafeDefinition $

353 "ALTER TABLE" <+> renderAlias table0

364 "ALTER TABLE" <+> renderAlias table0

354 <+> "RENAME TO" <+> renderAlias table1 <> ";"

365 <+> "RENAME TO" <+> renderAlias table1 <> ";"

355

366

356−-- | An `alterTableAddConstraint` adds a table constraint.

367+-- | An `addConstraint` adds a table constraint.

357--

368--

358-- >>> :{

369-- >>> :{

359-- let

370-- let

360-- definition :: Definition

371-- definition :: Definition

361−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

372+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

362−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

373+-- '["tab" ::: '["positive" ::: Check ] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

363−-- definition = alterTableAddConstraint #tab (check (#col .> 0))

374+-- definition = alterTable #tab (addConstraint #positive (check (#col .> 0)))

364-- in renderDefinition definition

375-- in renderDefinition definition

365-- :}

376-- :}

366−-- "ALTER TABLE tab ADD CHECK ((col > 0));"

377+-- "ALTER TABLE tab ADD CONSTRAINT positive 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−

376addConstraint

378addConstraint

377 :: KnownSymbol constraintName

379 :: KnownSymbol constraintName

378 => Alias constraintName

380 => Alias constraintName

379− -> TableConstraintExpression schema (UnconstrainColumns columns) constraint

381+ -> TableConstraintExpression schema (UnconstrainColumns (UnconstrainTable table)) constraint

380− -> AlterTable schema

381− (constraints :=> columns)

382− (Create constraintName constraint constraints :=> columns)

382+ -> AlterTable schema table (AddConstraint constraintName constraint table)

383addConstraint constraintName constraint = UnsafeAlterTable $

384 "ADD" <+> "CONSTRAINT" <+> renderAlias constraintName

385 <+> renderTableConstraintExpression constraint

@@ -421,7 +421,7 @@ addColumnDefault

421 :: KnownSymbol column

422 => Alias column -- ^ column to add

423 -> 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)

425addColumnDefault column ty = UnsafeAlterTable $

426 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

427

@@ -443,7 +443,7 @@ addColumnNull

443 :: KnownSymbol column

444 => Alias column -- ^ column to add

445 -> 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)

447addColumnNull column ty = UnsafeAlterTable $

448 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

449

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.

120

121>>> :set -XDataKinds

122>>> :set -XTypeOperators

123−>>> type Schema = '["tab" ::: '["col" ::: 'Required ('Null 'PGint2)]]

123+>>> type Schema = '["tab" ::: Unconstraint :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]]

124>>> :set -XTypeApplications

125>>> :set -XOverloadedStrings

126>>> 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

67 , NullifyTables

68 , Join

69 , Create

70− , Add

70+ , AddColumn

71+ , AddConstraint

71 , Drop

72 , Drop

72 , Alter

73 , Alter

73 , Rename

74 , Rename

@@ -76,6 +77,7 @@ module Squeal.PostgreSQL.Schema

76 , SameFields

77 , SameFields

77 -- * PostgreSQL Constraints

78 -- * PostgreSQL Constraints

78 , (:=>)

79 , (:=>)

80+ , Unconstraint

79 , UnconstrainColumn

81 , UnconstrainColumn

80 , UnconstrainColumns

82 , UnconstrainColumns

81 , UnconstrainTable

83 , UnconstrainTable

@@ -310,8 +312,11 @@ type family Create alias x xs where

310 Create alias x '[] = '[alias ::: x]

312 Create alias x '[] = '[alias ::: x]

311 Create alias y (x ': xs) = x ': Create alias y xs

313 Create alias y (x ': xs) = x ': Create alias y xs

312

314

313−type family Add alias x y where

315+type family AddColumn alias x y where

314− Add alias x (constraints :=> xs) = constraints :=> Create alias x xs

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

315

320

316-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

321-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

317-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

322-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

@@ -377,11 +382,12 @@ data ColumnConstraint

377

382

378data TableConstraint

383data TableConstraint

379 = Check

384 = Check

380− | Uniques [Symbol]

385+ | Unique [Symbol]

381 | PrimaryKey [Symbol]

386 | PrimaryKey [Symbol]

382 | ForeignKey [Symbol] Symbol [Symbol]

387 | ForeignKey [Symbol] Symbol [Symbol]

383

388

384type TableConstraints = [(Symbol,TableConstraint)]

389type TableConstraints = [(Symbol,TableConstraint)]

390+type Unconstraint = ('[] :: TableConstraints)

385

391

386type family Aliases xs where

392type family Aliases xs where

387 Aliases '[] = '[]

393 Aliases '[] = '[]