85e2bb9 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Merge pull request #124 from morphismtech/dev-column-expr

85e2bb9Eitan Chatav8 years ago

squeal-postgresql/exe/Example.hs+2−2

compare with dev

unifiedsplit

@@ -64,12 +64,12 @@ teardown = dropTable #emails >>> dropTable #users

65insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)

66insertUser = insertInto #users

67− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))

67+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))

68 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))

70insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()

71insertEmail = insertInto_ #emails

72− (Values_ (defaultAs #id :* param @1 `as` #user_id :* param @2 `as` #email))

72+ (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))

74getUsers :: Query_ Schemas () User

75getUsers = select_

squeal-postgresql/src/Squeal/PostgreSQL.hs+4−3

@@ -130,10 +130,11 @@ let

130 insertUser = with (u `as` #u) e

131 where

132 u = insertInto #users

133− (Values_ (defaultAs #id :* param @1 `as` #name))

133+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))

134 OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))

135− e = insertInto_ #emails

135+ e = insertInto_ #emails $ Select

136− (Select (defaultAs #id :* #u ! #id `as` #user_id :* #u ! #email) (from (common #u)))

136+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)

137+ (from (common #u))

137:}

138:}

138

139

139>>> printSQL insertUser

140>>> printSQL insertUser

squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−9

@@ -46,7 +46,6 @@ module Squeal.PostgreSQL.Alias

46 , HasIn

47 , QualifiedAlias (..)

48 , IsQualified (..)

49− , DefaultAliasable (..)

50 -- * Grouping

49 -- * Grouping

51 , Grouping (..)

50 , Grouping (..)

52 , GroupedBy

51 , GroupedBy

@@ -189,14 +188,6 @@ choose which subfields to update.

189class HasIn fields field where

188class HasIn fields field where

190instance (Has alias fields field) => HasIn fields (alias ::: field) where

189instance (Has alias fields field) => HasIn fields (alias ::: field) where

191

190

192−{- |

193−The `DefaultAliasable` class is intended to help with Scrap your Nils

194−for default inserts and updates.

195−-}

196−class KnownSymbol alias

197− => DefaultAliasable alias aliased | aliased -> alias where

198− defaultAs :: Alias alias -> aliased

199−

200-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer

191-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer

201-- a list of @subfields@.

192-- a list of @subfields@.

202class

193class

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+40−110

@@ -18,6 +18,7 @@ Squeal data manipulation language.

18 , MultiParamTypeClasses

19 , OverloadedStrings

20 , PatternSynonyms

21+ , QuantifiedConstraints

21 , RankNTypes

22 , RankNTypes

22 , ScopedTypeVariables

23 , ScopedTypeVariables

23 , TypeApplications

24 , TypeApplications

@@ -34,8 +35,7 @@ module Squeal.PostgreSQL.Manipulation

34 , queryStatement

35 , queryStatement

35 , QueryClause (..)

36 , QueryClause (..)

36 , pattern Values_

37 , pattern Values_

37− , DefaultAliasable (..)

38+ , Optional (..)

38− , ColumnExpression (..)

39 , ReturningClause (..)

40 , pattern Returning_

41 , ConflictClause (..)

@@ -56,7 +56,6 @@ module Squeal.PostgreSQL.Manipulation

56import Control.DeepSeq

57import Data.ByteString hiding (foldr)

58import Data.Kind (Type)

59−import GHC.TypeLits (KnownSymbol)

61import qualified Generics.SOP as SOP

60import qualified Generics.SOP as SOP

62import qualified GHC.Generics as GHC

61import qualified GHC.Generics as GHC

@@ -86,7 +85,7 @@ simple insert:

86let

85let

87 manipulation :: Manipulation '[] (Public Schema) '[] '[]

86 manipulation :: Manipulation '[] (Public Schema) '[] '[]

88 manipulation =

87 manipulation =

89− insertInto_ #tab (Values_ (2 `as` #col1 :* defaultAs #col2))

88+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))

90in printSQL manipulation

89in printSQL manipulation

91:}

90:}

92INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

91INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

@@ -99,7 +98,7 @@ parameterized insert:

99let

98let

100 manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

99 manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

101 manipulation =

100 manipulation =

102− insertInto_ #tab (Values_ (param @1 `as` #col1 :* param @2 `as` #col2))

101+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))

103in printSQL manipulation

102in printSQL manipulation

104:}

103:}

105INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

104INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

@@ -110,7 +109,7 @@ returning insert:

110let

109let

111 manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]

110 manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]

112 manipulation =

111 manipulation =

113− insertInto #tab (Values_ (2 `as` #col1 :* 3 `as` #col2))

112+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))

114 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))

113 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))

115in printSQL manipulation

114in printSQL manipulation

116:}

115:}

@@ -126,9 +125,9 @@ let

126 manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]

125 manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]

127 manipulation =

126 manipulation =

128 insertInto #customers

127 insertInto #customers

129− (Values_ ("John Smith" `as` #name :* "john@smith.com" `as` #email))

128+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))

130 (OnConflict (OnConstraint #uq)

129 (OnConflict (OnConstraint #uq)

131− (DoUpdate (((#excluded ! #email) <> "; " <> (#customers ! #email)) `as` #email) []))

130+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))

132 (Returning_ Nil)

131 (Returning_ Nil)

133in printSQL manipulation

132in printSQL manipulation

134:}

133:}

@@ -149,7 +148,7 @@ update:

149>>> :{

148>>> :{

150let

149let

151 manipulation :: Manipulation '[] (Public Schema) '[] '[]

150 manipulation :: Manipulation '[] (Public Schema) '[] '[]

152− manipulation = update_ #tab (2 `as` #col1) (#col1 ./= #col2)

151+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)

153in printSQL manipulation

152in printSQL manipulation

154:}

153:}

155UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

154UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

@@ -268,12 +267,12 @@ insertInto_ tab qry =

268data QueryClause commons schemas params columns where

267data QueryClause commons schemas params columns where

269 Values

268 Values

270 :: SOP.SListI columns

269 :: SOP.SListI columns

271− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns

270+ => NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[]))) columns

272− -> [NP (ColumnExpression 'Ungrouped schemas params '[]) columns]

271+ -> [NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[]))) columns]

273 -> QueryClause commons schemas params columns

272 -> QueryClause commons schemas params columns

274 Select

273 Select

275 :: SOP.SListI columns

274 :: SOP.SListI columns

276− => NP (ColumnExpression grp schemas params from) columns

275+ => NP (Aliased (Optional (Expression '[] '[] grp schemas params from))) columns

277 -> TableExpression '[] commons grp schemas params from

276 -> TableExpression '[] commons grp schemas params from

278 -> QueryClause commons schemas params columns

277 -> QueryClause commons schemas params columns

279 Subquery

278 Subquery

@@ -297,109 +296,34 @@ instance RenderSQL (QueryClause commons schemas params columns) where

297 Subquery qry -> renderQuery qry

296 Subquery qry -> renderQuery qry

298 where

297 where

299 renderSQLPartMaybe, renderValuePartMaybe

298 renderSQLPartMaybe, renderValuePartMaybe

300− :: ColumnExpression grp schemas params from column -> Maybe ByteString

299+ :: Aliased (Optional (Expression '[] '[] grp schemas params from)) column

300+ -> Maybe ByteString

301 renderSQLPartMaybe = \case

302− DefaultAs _ -> Nothing

302+ Default `As` _ -> Nothing

303− Specific (_ `As` name) -> Just $ renderSQL name

303+ Set _ `As` name -> Just $ renderSQL name

304 renderValuePartMaybe = \case

305− DefaultAs _ -> Nothing

305+ Default `As` _ -> Nothing

306− Specific (value `As` _) -> Just $ renderExpression value

306+ Set value `As` _ -> Just $ renderExpression value

307 renderSQLPart, renderValuePart

308− :: ColumnExpression grp schemas params from column -> ByteString

308+ :: Aliased (Optional (Expression '[] '[] grp schemas params from)) column

309− renderSQLPart = \case

309+ -> ByteString

310− DefaultAs name -> renderSQL name

311− Specific (_ `As` name) -> renderSQL name

310+ renderSQLPart (_ `As` name) = renderSQL name

312− renderValuePart = \case

311+ renderValuePart (value `As` _) = renderSQL value

313− DefaultAs _ -> "DEFAULT"

314− Specific (value `As` _) -> renderExpression value

315

312

316pattern Values_

313pattern Values_

317 :: SOP.SListI columns

314 :: SOP.SListI columns

318− => NP (ColumnExpression 'Ungrouped schemas params '[]) columns

315+ => NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[]))) columns

319 -> QueryClause commons schemas params columns

316 -> QueryClause commons schemas params columns

320pattern Values_ vals = Values vals []

317pattern Values_ vals = Values vals []

321

318

322−data ColumnExpression grp schemas params from column where

319+data Optional expr ty where

323− DefaultAs

320+ Default :: Optional expr ('Def :=> ty)

324− :: KnownSymbol col

321+ Set :: expr ty -> Optional expr (def :=> ty)

325− => Alias col

322+

326− -> ColumnExpression grp schemas params from (col ::: 'Def :=> ty)

323+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where

327− Specific

328− :: Aliased (Expression '[] '[] grp schemas params from) (col ::: ty)

329− -> ColumnExpression grp schemas params from (col ::: defness :=> ty)

330−

331−instance (KnownSymbol col, column ~ (col ::: defness :=> ty))

332− => Aliasable col

333− (Expression '[] '[] grp schemas params from ty)

334− (ColumnExpression grp schemas params from column) where

335− expression `as` col = Specific (expression `As` col)

336−instance (KnownSymbol col, columns ~ '[col ::: defness :=> ty])

337− => Aliasable col

338− (Expression '[] '[] grp schemas params from ty)

339− (NP (ColumnExpression grp schemas params from) columns) where

340− expression `as` col = expression `as` col :* Nil

341−instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))

342− => DefaultAliasable col (ColumnExpression grp schemas params from column) where

343− defaultAs = DefaultAs

344−instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])

345− => DefaultAliasable col (NP (ColumnExpression grp schemas params from) columns) where

346− defaultAs col = defaultAs col :* Nil

347−

348−instance (HasUnique tab from row, Has col row ty, column ~ (col ::: defness :=> ty))

349− => IsLabel col (ColumnExpression 'Ungrouped schemas params from column) where

350− fromLabel = fromLabel @col `as` Alias

351−instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])

352− => IsLabel col

353− (NP (ColumnExpression 'Ungrouped schemas params from) columns) where

354− fromLabel = fromLabel @col `as` Alias

355−

356−instance (Has tab from row, Has col row ty, column ~ (col ::: defness :=> ty))

357− => IsQualified tab col (ColumnExpression 'Ungrouped schemas params from column) where

358− tab ! col = tab ! col `as` col

359−instance (Has tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])

360− => IsQualified tab col (NP (ColumnExpression 'Ungrouped schemas params from) columns) where

361− tab ! col = tab ! col `as` col

362−

363−instance

364− ( HasUnique tab from row

365− , Has col row ty

366− , GroupedBy tab col bys

367− , column ~ (col ::: defness :=> ty)

368− ) => IsLabel col

369− (ColumnExpression ('Grouped bys) schemas params from column) where

370− fromLabel = fromLabel @col `as` Alias

371−instance

372− ( HasUnique tab from row

373− , Has col row ty

374− , GroupedBy tab col bys

375− , columns ~ '[col ::: defness :=> ty]

376− ) => IsLabel col

377− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where

378− fromLabel = fromLabel @col `as` Alias

379−

380−instance

381− ( Has tab from row

382− , Has col row ty

383− , GroupedBy tab col bys

384− , column ~ (col ::: defness :=> ty)

385− ) => IsQualified tab col

386− (ColumnExpression ('Grouped bys) schemas params from column) where

387− tab ! col = tab ! col `as` col

388−instance

389− ( Has tab from row

390− , Has col row ty

391− , GroupedBy tab col bys

392− , columns ~ '[col ::: defness :=> ty]

393− ) => IsQualified tab col

394− (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where

395− tab ! col = tab ! col :* Nil

396−

397−instance RenderSQL (ColumnExpression grp schemas params from column) where

398 renderSQL = \case

324 renderSQL = \case

399− DefaultAs col ->

400− renderSQL col <+> "=" <+> "DEFAULT"

325+ Default -> "DEFAULT"

401− Specific (expression `As` col) ->

326+ Set expr -> renderSQL expr

402− renderSQL col <+> "=" <+> renderSQL expression

403

327

404-- | A `ReturningClause` computes and return value(s) based

328-- | A `ReturningClause` computes and return value(s) based

405-- on each row actually inserted, updated or deleted. This is primarily

329-- on each row actually inserted, updated or deleted. This is primarily

@@ -453,7 +377,7 @@ data ConflictAction tab commons schemas params columns where

453 , columns ~ (col0 ': cols)

377 , columns ~ (col0 ': cols)

454 , SOP.All (HasIn columns) subcolumns

378 , SOP.All (HasIn columns) subcolumns

455 , AllUnique subcolumns )

379 , AllUnique subcolumns )

456− => NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]) subcolumns

380+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns

457 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]

381 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]

458 -> ConflictAction tab commons schemas params columns

382 -> ConflictAction tab commons schemas params columns

459

383

@@ -462,11 +386,17 @@ instance RenderSQL (ConflictAction tab commons schemas params columns) where

462 DoNothing -> "DO NOTHING"

386 DoNothing -> "DO NOTHING"

463 DoUpdate updates whs'

387 DoUpdate updates whs'

464 -> "DO UPDATE SET"

388 -> "DO UPDATE SET"

465− <+> renderCommaSeparated renderSQL updates

389+ <+> renderCommaSeparated renderUpdate updates

466 <> case whs' of

390 <> case whs' of

467 [] -> ""

391 [] -> ""

468 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

392 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

469

393

394+renderUpdate

395+ :: (forall x. RenderSQL (expr x))

396+ => Aliased (Optional expr) ty

397+ -> ByteString

398+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr

399+

470-- | A `ConflictTarget` specifies the constraint violation that triggers a

400-- | A `ConflictTarget` specifies the constraint violation that triggers a

471-- `ConflictAction`.

401-- `ConflictAction`.

472data ConflictTarget constraints where

402data ConflictTarget constraints where

@@ -497,7 +427,7 @@ update

497 , SOP.All (HasIn columns) subcolumns

427 , SOP.All (HasIn columns) subcolumns

498 , AllUnique subcolumns )

428 , AllUnique subcolumns )

499 => QualifiedAlias sch tab -- ^ table to update

429 => QualifiedAlias sch tab -- ^ table to update

500− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row0]) subcolumns

430+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns

501 -- ^ modified values to replace old values

431 -- ^ modified values to replace old values

502 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

432 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

503 -- ^ condition under which to perform update on a row

433 -- ^ condition under which to perform update on a row

@@ -507,7 +437,7 @@ update tab columns wh returning = UnsafeManipulation $

507 "UPDATE"

437 "UPDATE"

508 <+> renderSQL tab

438 <+> renderSQL tab

509 <+> "SET"

439 <+> "SET"

510− <+> renderCommaSeparated renderSQL columns

440+ <+> renderCommaSeparated renderUpdate columns

511 <+> "WHERE" <+> renderSQL wh

441 <+> "WHERE" <+> renderSQL wh

512 <> renderSQL returning

442 <> renderSQL returning

513

443

@@ -522,7 +452,7 @@ update_

522 , SOP.All (HasIn columns) subcolumns

452 , SOP.All (HasIn columns) subcolumns

523 , AllUnique subcolumns )

453 , AllUnique subcolumns )

524 => QualifiedAlias sch tab -- ^ table to update

454 => QualifiedAlias sch tab -- ^ table to update

525− -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row]) subcolumns

455+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns

526 -- ^ modified values to replace old values

456 -- ^ modified values to replace old values

527 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

457 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

528 -- ^ condition under which to perform update on a row

458 -- ^ condition under which to perform update on a row

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+1−1

@@ -339,7 +339,7 @@ createMigrations =

339-- the time at which it was inserted.

340insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

341insertMigration = insertInto_ #schema_migrations

342− (Values_ ((param @1) `as` #name :* defaultAs #executed_at))

342+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))

343

344-- | Deletes a `Migration` from the `MigrationsTable`, returning

345-- the time at which it was inserted.

squeal-postgresql/test/Specs/ExceptionHandling.hs+1−1

@@ -59,7 +59,7 @@ instance SOP.HasDatatypeInfo User

59insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]

60 '[ "fromOnly" ::: 'NotNull 'PGint4 ]

61insertUser = insertInto #users

62− (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))

62+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))

63 OnConflictDoRaise (Returning (#id `as` #fromOnly))

65setup :: Definition (Public '[]) Schemas