squeal-postgresql 0.6.0.2 → 0.7.0.0
raw patch · 52 files changed
+2353/−606 lines, 52 filesdep +exceptionsdep +monad-controldep +transformers-basedep ~aesondep ~basedep ~binary
Dependencies added: exceptions, monad-control, transformers-base
Dependency ranges changed: aeson, base, binary, bytestring, bytestring-strict-builder, deepseq, doctest, generic-random, generics-sop, hedgehog, hspec, mmorph, mtl, network-ip, postgresql-binary, postgresql-libpq, profunctors, records-sop, scientific, text, time, transformers, unliftio, unliftio-pool, vector
Files
- README.md +1/−1
- bench/Gauge/DBHelpers.hs +1/−8
- bench/Gauge/DBSetup.hs +2/−4
- bench/Gauge/Queries.hs +1/−5
- bench/Gauge/Schema.hs +1/−1
- exe/Example.hs +61/−19
- squeal-postgresql.cabal +54/−47
- src/Squeal/PostgreSQL.hs +7/−4
- src/Squeal/PostgreSQL/Definition/Comment.hs +165/−0
- src/Squeal/PostgreSQL/Definition/Constraint.hs +49/−39
- src/Squeal/PostgreSQL/Definition/Procedure.hs +171/−0
- src/Squeal/PostgreSQL/Definition/Table.hs +47/−8
- src/Squeal/PostgreSQL/Definition/Type.hs +44/−0
- src/Squeal/PostgreSQL/Definition/View.hs +44/−0
- src/Squeal/PostgreSQL/Expression.hs +17/−24
- src/Squeal/PostgreSQL/Expression/Aggregate.hs +16/−2
- src/Squeal/PostgreSQL/Expression/Array.hs +100/−2
- src/Squeal/PostgreSQL/Expression/Comparison.hs +1/−1
- src/Squeal/PostgreSQL/Expression/Inline.hs +26/−21
- src/Squeal/PostgreSQL/Expression/Null.hs +3/−3
- src/Squeal/PostgreSQL/Expression/Parameter.hs +7/−7
- src/Squeal/PostgreSQL/Expression/Range.hs +1/−1
- src/Squeal/PostgreSQL/Expression/Type.hs +1/−0
- src/Squeal/PostgreSQL/Expression/Window.hs +5/−1
- src/Squeal/PostgreSQL/Manipulation.hs +145/−94
- src/Squeal/PostgreSQL/Manipulation/Call.hs +117/−0
- src/Squeal/PostgreSQL/Manipulation/Delete.hs +30/−26
- src/Squeal/PostgreSQL/Manipulation/Insert.hs +39/−10
- src/Squeal/PostgreSQL/Manipulation/Update.hs +53/−16
- src/Squeal/PostgreSQL/Query.hs +121/−115
- src/Squeal/PostgreSQL/Query/From.hs +5/−1
- src/Squeal/PostgreSQL/Query/From/Join.hs +1/−3
- src/Squeal/PostgreSQL/Query/Select.hs +4/−4
- src/Squeal/PostgreSQL/Query/Table.hs +123/−4
- src/Squeal/PostgreSQL/Query/With.hs +54/−12
- src/Squeal/PostgreSQL/Session.hs +52/−2
- src/Squeal/PostgreSQL/Session/Connection.hs +1/−1
- src/Squeal/PostgreSQL/Session/Decode.hs +124/−2
- src/Squeal/PostgreSQL/Session/Encode.hs +9/−7
- src/Squeal/PostgreSQL/Session/Migration.hs +19/−21
- src/Squeal/PostgreSQL/Session/Monad.hs +408/−16
- src/Squeal/PostgreSQL/Session/Oid.hs +1/−1
- src/Squeal/PostgreSQL/Session/Pool.hs +4/−4
- src/Squeal/PostgreSQL/Session/Result.hs +48/−5
- src/Squeal/PostgreSQL/Session/Transaction.hs +1/−1
- src/Squeal/PostgreSQL/Type.hs +42/−3
- src/Squeal/PostgreSQL/Type/Alias.hs +12/−4
- src/Squeal/PostgreSQL/Type/List.hs +1/−10
- src/Squeal/PostgreSQL/Type/PG.hs +2/−8
- src/Squeal/PostgreSQL/Type/Schema.hs +34/−24
- test/Property.hs +37/−10
- test/Spec.hs +41/−4
README.md view
@@ -1,6 +1,6 @@ # squeal-postgresql -+ [](https://circleci.com/gh/morphismtech/squeal)
bench/Gauge/DBHelpers.hs view
@@ -14,21 +14,14 @@ module Gauge.DBHelpers where -import Data.ByteString ( ByteString ) import qualified Data.ByteString.Char8 as C import qualified Data.Text as T import Control.Monad ( void )-import Control.Monad.Except ( MonadIO- , throwError- ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Loops ( iterateWhile )-import GHC.Generics ( Generic- , Generic1- )+import GHC.Generics ( Generic ) import Test.QuickCheck import Squeal.PostgreSQL-import qualified Data.ByteString.Char8 as C import Control.DeepSeq -- Project imports import Gauge.Schema ( Schemas )
bench/Gauge/DBSetup.hs view
@@ -17,14 +17,12 @@ import qualified Data.ByteString.Char8 as C import Control.Monad ( void ) import GHC.Generics-import Test.QuickCheck import Squeal.PostgreSQL -- Project imports import Gauge.Schema ( Schemas , DeviceOS , IPLocation )-import Gauge.Queries ( InsertUser ) -- First create enums as they're needed in the Schema@@ -59,7 +57,7 @@ ) ( primaryKey #id `as` #pk_user_devices- :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade+ :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id :* unique #token `as` #token@@ -99,7 +97,7 @@ <> show portNumber connectionString :: ByteString-connectionString = "host=localhost port=5432 dbname=exampledb"+connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" performDBAction :: Definition a b -> String -> IO () performDBAction action message = do
bench/Gauge/Queries.hs view
@@ -21,11 +21,7 @@ import Data.Int ( Int16 , Int64 )-import Test.QuickCheck ( Arbitrary(..)- , PrintableString(..)- , listOf- , arbitraryPrintableChar- )+import Test.QuickCheck ( Arbitrary(..) ) import Generic.Random ( genericArbitrarySingle ) -- Import Orphan instances import Test.QuickCheck.Instances ( )
bench/Gauge/Schema.hs view
@@ -72,7 +72,7 @@ type UserDevicesConstraints = '[ "pk_user_devices" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] , "token" ::: 'Unique '["token"] ]
exe/Example.hs view
@@ -9,7 +9,7 @@ , TypeOperators #-} -module Main (main, main2) where+module Main (main, main2, upsertUser) where import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32)@@ -22,7 +22,7 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC -type Schema =+type UserSchema = '[ "users" ::: 'Table ( '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4@@ -31,54 +31,96 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "user" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4 , "email" ::: 'NoDef :=> 'Null 'PGtext ])- , "positive" ::: 'Typedef 'PGfloat4 ] -type Schemas = Public Schema+type PublicSchema = '[ "positive" ::: 'Typedef 'PGfloat4 ] +type OrgSchema =+ '[ "organizations" ::: 'Table (+ '[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ ])+ , "members" ::: 'Table (+ '[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"]+ , "fk_organization" ::: 'ForeignKey '["organization"] "org" "organizations" '["id"] ] :=>+ '[ "member" ::: 'NoDef :=> 'NotNull 'PGint4+ , "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ])+ ]++type Schemas + = '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ]+ setup :: Definition (Public '[]) Schemas setup =- createTable #users+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))+ >>>+ createSchema #user+ >>>+ createSchema #org+ >>>+ createTable (#user ! #jokers) ( serial `as` #id :* (text & notNullable) `as` #name :* (vararray int2 & notNullable) `as` #vec ) ( primaryKey #id `as` #pk_users ) >>>- createTable #emails+ alterTableRename (#user ! #jokers) #users+ >>>+ createTable (#user ! #emails) ( serial `as` #id :* columntypeFrom @Int32 `as` #user_id :* columntypeFrom @(Maybe Text) `as` #email ) ( primaryKey #id `as` #pk_emails :*- foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )- >>>- createDomain #positive real (#value .> 0 .&& (#value & isNotNull))-+ foreignKey #user_id (#user ! #users) #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id )+ >>>+ createTable (#org ! #organizations)+ ( serial `as` #id :*+ (text & notNullable) `as` #name )+ ( primaryKey #id `as` #pk_organizations )+ >>>+ createTable (#org ! #members)+ ( notNullable int4 `as` #member :*+ notNullable int4 `as` #organization )+ ( foreignKey #member (#user ! #users) #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_member :*+ foreignKey #organization (#org ! #organizations) #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_organization )+ teardown :: Definition Schemas (Public '[])-teardown = dropType #positive >>> dropTable #emails >>> dropTable #users+teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)-insertUser = insertInto #users+insertUser = insertInto (#user ! #users) (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly)) insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()-insertEmail = insertInto_ #emails+insertEmail = insertInto_ (#user ! #emails) (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) getUsers :: Query_ Schemas () User getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)- ( from (table (#users `as` #u)- & innerJoin (table (#emails `as` #e))+ ( from (table ((#user ! #users) `as` #u)+ & innerJoin (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id)) ) +upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) ()+upsertUser = insertInto (#user ! #users `as` #u)+ (Values_ (Set (param @1) `as` #id :* setUser))+ (OnConflict (OnConstraint #pk_users) (DoUpdate setUser [#u ! #id .== param @1]))+ (Returning_ Nil)+ where+ setUser = Set (param @2) `as` #name :* Set (param @3) `as` #vec :* Nil+ data User = User { userName :: Text@@ -110,7 +152,7 @@ main = do Char8.putStrLn "squeal" connectionString <- pure- "host=localhost port=5432 dbname=exampledb"+ "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Char8.putStrLn $ "connecting to " <> connectionString connection0 <- connectdb connectionString Char8.putStrLn "setting up schema"@@ -122,7 +164,7 @@ main2 :: IO () main2 =- withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup & pqThen session & pqThen (define teardown)
squeal-postgresql.cabal view
@@ -1,5 +1,5 @@ name: squeal-postgresql-version: 0.6.0.2+version: 0.7.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal@@ -23,11 +23,13 @@ exposed-modules: Squeal.PostgreSQL Squeal.PostgreSQL.Definition+ Squeal.PostgreSQL.Definition.Comment Squeal.PostgreSQL.Definition.Constraint Squeal.PostgreSQL.Definition.Function Squeal.PostgreSQL.Definition.Index Squeal.PostgreSQL.Definition.Table Squeal.PostgreSQL.Definition.Type+ Squeal.PostgreSQL.Definition.Procedure Squeal.PostgreSQL.Definition.Schema Squeal.PostgreSQL.Definition.View Squeal.PostgreSQL.Expression@@ -51,6 +53,7 @@ Squeal.PostgreSQL.Expression.Type Squeal.PostgreSQL.Expression.Window Squeal.PostgreSQL.Manipulation+ Squeal.PostgreSQL.Manipulation.Call Squeal.PostgreSQL.Manipulation.Delete Squeal.PostgreSQL.Manipulation.Insert Squeal.PostgreSQL.Manipulation.Update@@ -84,31 +87,34 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- aeson >= 1.2.4.0- , base >= 4.11.1.0 && < 5.0- , binary >= 0.8.6.0+ aeson >= 1.4.7.1+ , base >= 4.13.0.0 && < 5.0+ , binary >= 0.8.7.0 , binary-parser >= 0.5.5- , bytestring >= 0.10.8.2- , bytestring-strict-builder >= 0.4.5- , deepseq >= 1.4.3.0+ , bytestring >= 0.10.10.0+ , bytestring-strict-builder >= 0.4.5.3+ , deepseq >= 1.4.4.0+ , exceptions >= 0.10.3 , free-categories >= 0.2.0.0- , generics-sop >= 0.3.2.0- , mmorph >= 1.1.1+ , generics-sop >= 0.5.1.0+ , mmorph >= 1.1.3+ , monad-control >= 1.0.2.3 , mtl >= 2.2.2- , network-ip >= 0.3.0.2- , postgresql-binary >= 0.12.1- , postgresql-libpq >= 0.9.4.1- , profunctors >= 5.3- , records-sop >= 0.1.0.0+ , network-ip >= 0.3.0.3+ , postgresql-binary >= 0.12.2+ , postgresql-libpq >= 0.9.4.2+ , profunctors >= 5.5.2+ , records-sop >= 0.1.0.3 , resource-pool >= 0.2.3.2- , scientific >= 0.3.5.3- , text >= 1.2.3.0- , time >= 1.8.0.2- , transformers >= 0.5.2.0- , unliftio >= 0.2.10- , unliftio-pool >= 0.2.1.0+ , scientific >= 0.3.6.2+ , text >= 1.2.3.2+ , time >= 1.9.3+ , transformers >= 0.5.6.2+ , transformers-base >= 0.4.5.2+ , unliftio >= 0.2.12.1+ , unliftio-pool >= 0.2.1.1 , uuid-types >= 1.0.3- , vector >= 0.12.0.1+ , vector >= 0.12.1.2 test-suite doctest default-language: Haskell2010@@ -117,8 +123,8 @@ ghc-options: -Wall main-is: Doc.hs build-depends:- base >= 4.10.0.0- , doctest >= 0.11.4+ base >= 4.13.0.0 && < 5.0+ , doctest >= 0.16.3 , squeal-postgresql test-suite properties@@ -128,13 +134,14 @@ ghc-options: -Wall main-is: Property.hs build-depends:- base >= 4.10.0.0- , bytestring >= 0.10.8.2- , hedgehog >= 1.0+ base >= 4.13.0.0 && < 5.0+ , bytestring >= 0.10.10.0+ , hedgehog >= 1.0.2+ , generics-sop >= 0.5.1.0 , mtl >= 2.2.2- , scientific >= 0.3.5.3+ , scientific >= 0.3.6.2 , squeal-postgresql- , time >= 1.8.0.2+ , time >= 1.9.3 , with-utf8 >= 1.0 test-suite spec@@ -145,14 +152,14 @@ main-is: Spec.hs build-depends: async >= 2.2.2- , base >= 4.10.0.0- , bytestring >= 0.10.8.2- , generics-sop >= 0.3.1.0- , hspec >= 2.4.8+ , base >= 4.13.0.0 && < 5.0+ , bytestring >= 0.10.10.0+ , generics-sop >= 0.5.1.0+ , hspec >= 2.7.1 , mtl >= 2.2.2 , squeal-postgresql- , text >= 1.2.2.2- , vector >= 0.12.0.1+ , text >= 1.2.3.2+ , vector >= 0.12.1.2 benchmark gauge type: exitcode-stdio-1.0@@ -171,19 +178,19 @@ -rtsopts -funbox-strict-fields build-depends:- base >= 4.10.0.0- , bytestring >= 0.10.8.2- , deepseq >= 1.4.3.0+ base >= 4.13.0.0 && < 5.0+ , bytestring >= 0.10.10.0+ , deepseq >= 1.4.4.0 , gauge >= 0.2.5- , generic-random >= 1.2.0.0- , generics-sop >= 0.3.1.0+ , generic-random >= 1.3.0.1+ , generics-sop >= 0.5.1.0 , monad-loops >= 0.4.3 , mtl >= 2.2.2 , QuickCheck >= 2.13.2 , quickcheck-instances >= 0.3.22- , scientific >= 0.3.5.3+ , scientific >= 0.3.6.2 , squeal-postgresql- , text >= 1.2.2.2+ , text >= 1.2.3.2 , with-utf8 >= 1.0 executable example@@ -193,10 +200,10 @@ main-is: Example.hs build-depends: base >= 4.10.0.0 && < 5.0- , bytestring >= 0.10.8.2- , generics-sop >= 0.3.1.0- , mtl >= 2.2.1+ , bytestring >= 0.10.10.0+ , generics-sop >= 0.5.1.0+ , mtl >= 2.2.2 , squeal-postgresql- , text >= 1.2.2.2- , transformers >= 0.5.2.0- , vector >= 0.12.0.1+ , text >= 1.2.3.2+ , transformers >= 0.5.6.2+ , vector >= 0.12.1.2
src/Squeal/PostgreSQL.hs view
@@ -40,7 +40,7 @@ , "email" ::: 'NoDef :=> 'Null 'PGtext ] type EmailsConstraints = '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] type Schema = '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]@@ -78,7 +78,7 @@ (text & nullable) `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) :} We can easily see the generated SQL is unsurprising looking.@@ -136,7 +136,7 @@ :} >>> printSQL insertUser-WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"+WITH "u" AS (INSERT INTO "users" AS "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" AS "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u" Next we write a `Statement` to retrieve users from the database. We're not interested in the ids here, just the usernames and email addresses. We@@ -184,7 +184,7 @@ usersRows <- getRows usersResult liftIO $ print usersRows in- withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup & pqThen session & pqThen (define teardown)@@ -198,9 +198,11 @@ ) where import Squeal.PostgreSQL.Definition as X+import Squeal.PostgreSQL.Definition.Comment as X import Squeal.PostgreSQL.Definition.Constraint as X import Squeal.PostgreSQL.Definition.Function as X import Squeal.PostgreSQL.Definition.Index as X+import Squeal.PostgreSQL.Definition.Procedure as X import Squeal.PostgreSQL.Definition.Schema as X import Squeal.PostgreSQL.Definition.Table as X import Squeal.PostgreSQL.Definition.Type as X@@ -226,6 +228,7 @@ import Squeal.PostgreSQL.Expression.Type as X import Squeal.PostgreSQL.Expression.Window as X import Squeal.PostgreSQL.Manipulation as X+import Squeal.PostgreSQL.Manipulation.Call as X import Squeal.PostgreSQL.Manipulation.Delete as X import Squeal.PostgreSQL.Manipulation.Insert as X import Squeal.PostgreSQL.Manipulation.Update as X
+ src/Squeal/PostgreSQL/Definition/Comment.hs view
@@ -0,0 +1,165 @@+{- |+Module: Squeal.PostgreSQL.Definition.Constraint+Description: comments+Copyright: (c) Eitan Chatav, 2020+Maintainer: eitan@morphism.tech+Stability: experimental+ +comments+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeInType+ , TypeOperators+ , UndecidableSuperClasses+ #-}++module Squeal.PostgreSQL.Definition.Comment+ ( commentOnTable+ , commentOnType+ , commentOnView+ , commentOnFunction+ , commentOnIndex+ , commentOnColumn+ , commentOnSchema+ ) where++import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema+import GHC.TypeLits (KnownSymbol)+import Data.Text (Text)++{-----------------------------------------+COMMENT statements+-----------------------------------------}++{- |+When a user views a table in the database (i.e. with \d+ <table>), it is useful+to be able to read a description of the table.+-}+commentOnTable+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , Has sch db schema+ , Has tab schema ('Table table)+ )+ => QualifiedAlias sch tab -- ^ table+ -> Text -- ^ comment+ -> Definition db db+commentOnTable alias comm = UnsafeDefinition $+ "COMMENT ON TABLE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a type in the database (i.e with \dT <type>), it is useful to+be able to read a description of the type.+-}+commentOnType+ :: ( KnownSymbol sch+ , KnownSymbol typ+ , Has sch db schema+ , Has typ schema ('Typedef type_)+ )+ => QualifiedAlias sch typ -- ^ type+ -> Text -- ^ comment+ -> Definition db db+commentOnType alias comm = UnsafeDefinition $+ "COMMENT ON TYPE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a view in the database (i.e. with \dv <view>), it is useful+to be able to read a description of the view.+-}+commentOnView+ :: ( KnownSymbol sch+ , KnownSymbol vie+ , Has sch db schema+ , Has vie schema ('View view)+ )+ => QualifiedAlias sch vie -- ^ view+ -> Text -- ^ comment+ -> Definition db db+commentOnView alias comm = UnsafeDefinition $+ "COMMENT ON VIEW" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views an index in the database (i.e. with \di+ <index>), it is+useful to be able to read a description of the index.+-}+commentOnIndex+ :: ( KnownSymbol sch+ , KnownSymbol ind+ , Has sch db schema+ , Has ind schema ('Index index)+ )+ => QualifiedAlias sch ind -- ^ index+ -> Text -- ^ comment+ -> Definition db db+commentOnIndex alias comm = UnsafeDefinition $+ "COMMENT ON INDEX" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a function in the database (i.e. with \df+ <function>), it is+useful to be able to read a description of the function.+-}+commentOnFunction+ :: ( KnownSymbol sch+ , KnownSymbol fun+ , Has sch db schema+ , Has fun schema ('Function function)+ )+ => QualifiedAlias sch fun -- ^ function+ -> Text -- ^ comment+ -> Definition db db+commentOnFunction alias comm = UnsafeDefinition $+ "COMMENT ON FUNCTION" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a table in the database (i.e. with \d+ <table>), it is useful+to be able to view descriptions of the columns in that table.+-}+commentOnColumn+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , KnownSymbol col+ , Has sch db schema+ , Has tab schema ('Table '(cons, cols))+ , Has col cols '(def, nulltyp)+ )+ => QualifiedAlias sch tab -- ^ table+ -> Alias col -- ^ column+ -> Text -- ^ comment+ -> Definition db db+commentOnColumn table col comm = UnsafeDefinition $+ "COMMENT ON COLUMN" <+> renderSQL table <> "." <> renderSQL col <+> "IS"+ <+> singleQuotedText comm <> ";"++{- |+When a user views a schema in the database (i.e. with \dn+ <schema>), it is+useful to be able to read a description.+-}+commentOnSchema+ :: ( KnownSymbol sch+ , Has sch db schema+ )+ => Alias sch -- ^ schema+ -> Text -- ^ comment+ -> Definition db db+commentOnSchema schema comm = UnsafeDefinition $+ "COMMENT ON SCHEMA" <+> renderSQL schema <> "IS" <+> singleQuotedText comm <> ";"
src/Squeal/PostgreSQL/Definition/Constraint.hs view
@@ -40,6 +40,7 @@ , ForeignKeyed , OnDeleteClause (..) , OnUpdateClause (..)+ , ReferentialAction (..) ) where import Control.DeepSeq@@ -200,7 +201,7 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4@@ -223,7 +224,7 @@ (text & nullable) `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) in printSQL setup :} CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));@@ -235,7 +236,7 @@ type Schema = '[ "employees" ::: 'Table ( '[ "employees_pk" ::: 'PrimaryKey '["id"]- , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "public" "employees" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext@@ -254,20 +255,23 @@ (integer & nullable) `as` #employer_id ) ( primaryKey #id `as` #employees_pk :* foreignKey #employer_id #employees #id- OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )+ (OnDelete Cascade) (OnUpdate Cascade) `as` #employees_employer_fk ) in printSQL setup :} CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE); -} foreignKey- :: (ForeignKeyed db sch schema child parent+ :: (ForeignKeyed db + sch0 sch1+ schema0 schema1 + child parent table reftable columns refcolumns constraints cols reftys tys ) => NP Alias columns -- ^ column or columns in the table- -> Alias parent+ -> QualifiedAlias sch0 parent -- ^ reference table -> NP Alias refcolumns -- ^ reference column or columns in the reference table@@ -275,8 +279,8 @@ -- ^ what to do when reference is deleted -> OnUpdateClause -- ^ what to do when reference is updated- -> TableConstraintExpression sch child db- ('ForeignKey columns parent refcolumns)+ -> TableConstraintExpression sch1 child db+ ('ForeignKey columns sch0 parent refcolumns) foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $ "FOREIGN KEY" <+> parenthesized (renderSQL keys) <+> "REFERENCES" <+> renderSQL parent@@ -286,16 +290,17 @@ -- | A constraint synonym between types involved in a foreign key constraint. type ForeignKeyed db- sch- schema+ sch0 sch1+ schema0 schema1 child parent table reftable columns refcolumns constraints cols reftys tys =- ( Has sch db schema- , Has child schema ('Table table)- , Has parent schema ('Table reftable)+ ( Has sch0 db schema0+ , Has sch1 db schema1+ , Has parent schema0 ('Table reftable)+ , Has child schema1 ('Table table) , HasAll columns (TableToColumns table) tys , reftable ~ (constraints :=> cols) , HasAll refcolumns cols reftys@@ -303,39 +308,44 @@ , Uniquely refcolumns constraints ) -- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.-data OnDeleteClause- = OnDeleteNoAction- -- ^ if any referencing rows still exist when the constraint is checked,- -- an error is raised- | OnDeleteRestrict -- ^ prevents deletion of a referenced row- | OnDeleteCascade- -- ^ specifies that when a referenced row is deleted,- -- row(s) referencing it should be automatically deleted as well+newtype OnDeleteClause = OnDelete ReferentialAction deriving (GHC.Generic,Show,Eq,Ord) instance NFData OnDeleteClause--- | Render `OnDeleteClause`. instance RenderSQL OnDeleteClause where- renderSQL = \case- OnDeleteNoAction -> "ON DELETE NO ACTION"- OnDeleteRestrict -> "ON DELETE RESTRICT"- OnDeleteCascade -> "ON DELETE CASCADE"+ renderSQL (OnDelete action) = "ON DELETE" <+> renderSQL action -- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked -- when a referenced column is changed (updated).-data OnUpdateClause- = OnUpdateNoAction- -- ^ if any referencing rows has not changed when the constraint is checked,- -- an error is raised- | OnUpdateRestrict -- ^ prevents update of a referenced row- | OnUpdateCascade- -- ^ the updated values of the referenced column(s) should be copied- -- into the referencing row(s)+newtype OnUpdateClause = OnUpdate ReferentialAction deriving (GHC.Generic,Show,Eq,Ord) instance NFData OnUpdateClause---- | Render `OnUpdateClause`. instance RenderSQL OnUpdateClause where+ renderSQL (OnUpdate action) = "ON UPDATE" <+> renderSQL action++{- | When the data in the referenced columns is changed,+certain actions are performed on the data in this table's columns.-}+data ReferentialAction+ = NoAction+ {- ^ Produce an error indicating that the deletion or update+ would create a foreign key constraint violation.+ If the constraint is deferred, this error will be produced+ at constraint check time if there still exist any referencing rows.-}+ | Restrict+ {- ^ Produce an error indicating that the deletion or update+ would create a foreign key constraint violation.+ This is the same as `NoAction` except that the check is not deferrable.-}+ | Cascade+ {- ^ Delete any rows referencing the deleted row,+ or update the value of the referencing column+ to the new value of the referenced column, respectively.-}+ | SetNull {- ^ Set the referencing column(s) to null.-}+ | SetDefault {- ^ Set the referencing column(s) to their default values.-}+ deriving (GHC.Generic,Show,Eq,Ord)+instance NFData ReferentialAction+instance RenderSQL ReferentialAction where renderSQL = \case- OnUpdateNoAction -> "ON UPDATE NO ACTION"- OnUpdateRestrict -> "ON UPDATE RESTRICT"- OnUpdateCascade -> "ON UPDATE CASCADE"+ NoAction -> "NO ACTION"+ Restrict -> "RESTRICT"+ Cascade -> "CASCADE"+ SetNull -> "SET NULL"+ SetDefault -> "SET DEFAULT"
+ src/Squeal/PostgreSQL/Definition/Procedure.hs view
@@ -0,0 +1,171 @@+{-|+Module: Squeal.PostgreSQL.Definition.Procedure+Description: create and drop procedures+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop procedures+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeInType+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Procedure+ ( -- * Create+ createProcedure+ , createOrReplaceProcedure+ -- * Drop+ , dropProcedure+ , dropProcedureIfExists+ -- * Procedure Definition+ , ProcedureDefinition(..)+ , languageSqlManipulation+ ) where++import Control.DeepSeq+import Data.ByteString+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | Create a procedure.++>>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ]+>>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ])+>>> :{+let+ definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc])+ definition = createProcedure #proc (one int4) + . languageSqlManipulation+ $ [deleteFrom_ #things (#id .== param @1)]+in printSQL definition+:}+CREATE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$;+-}+createProcedure+ :: ( Has sch db schema+ , KnownSymbol pro+ , SOP.SListI args )+ => QualifiedAlias sch pro -- ^ procedure alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> ProcedureDefinition db args -- ^ procedure definition+ -> Definition db (Alter sch (Create pro ('Procedure args) schema) db)+createProcedure pro args prodef = UnsafeDefinition $+ "CREATE" <+> "PROCEDURE" <+> renderSQL pro+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> renderSQL prodef <> ";"++{- | Create or replace a procedure.+It is not possible to change the name or argument types+of a procedure this way.++>>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ]+>>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ])+>>> :{+let+ definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc])+ definition = createOrReplaceProcedure #proc (one int4) + . languageSqlManipulation+ $ [deleteFrom_ #things (#id .== param @1)]+in printSQL definition+:}+CREATE OR REPLACE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$;+-}+createOrReplaceProcedure+ :: ( Has sch db schema+ , KnownSymbol pro+ , SOP.SListI args )+ => QualifiedAlias sch pro -- ^ procedure alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> ProcedureDefinition db args -- ^ procedure definition+ -> Definition db (Alter sch (CreateOrReplace pro ('Procedure args) schema) db)+createOrReplaceProcedure pro args prodef = UnsafeDefinition $+ "CREATE" <+> "OR" <+> "REPLACE" <+> "PROCEDURE" <+> renderSQL pro+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> renderSQL prodef <> ";"++-- | Use a parameterized `Manipulation` as a procedure body+languageSqlManipulation+ :: [Manipulation '[] db args '[]]+ -- ^ procedure body+ -> ProcedureDefinition db args+languageSqlManipulation mnps = UnsafeProcedureDefinition $+ "language sql as" <+> "$$" <+> Prelude.foldr (<+>) "" (Prelude.map ((<> ";") . renderSQL) mnps) <> "$$"++-- | ++{- | Drop a procedure.++>>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4]+>>> :{+let+ definition :: Definition (Public '["proc" ::: Proc]) (Public '[])+ definition = dropProcedure #proc+in printSQL definition+:}+DROP PROCEDURE "proc";+-}+dropProcedure+ :: (Has sch db schema, KnownSymbol pro)+ => QualifiedAlias sch pro+ -- ^ procedure alias+ -> Definition db (Alter sch (DropSchemum pro 'Procedure schema) db)+dropProcedure pro = UnsafeDefinition $+ "DROP PROCEDURE" <+> renderSQL pro <> ";"++{- | Drop a procedure.++>>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4 ]+>>> :{+let+ definition :: Definition (Public '[]) (Public '[])+ definition = dropProcedureIfExists #proc+in printSQL definition+:}+DROP PROCEDURE IF EXISTS "proc";+-}+dropProcedureIfExists+ :: (Has sch db schema, KnownSymbol pro)+ => QualifiedAlias sch pro+ -- ^ procedure alias+ -> Definition db (Alter sch (DropSchemumIfExists pro 'Procedure schema) db)+dropProcedureIfExists pro = UnsafeDefinition $+ "DROP PROCEDURE IF EXISTS" <+> renderSQL pro <> ";"++{- | Body of a user defined procedure-}+newtype ProcedureDefinition db args = UnsafeProcedureDefinition+ { renderProcedureDefinition :: ByteString }+ deriving (Eq,Show,GHC.Generic,NFData)+instance RenderSQL (ProcedureDefinition db args) where+ renderSQL = renderProcedureDefinition
src/Squeal/PostgreSQL/Definition/Table.hs view
@@ -41,6 +41,7 @@ , alterTableIfExists , alterTableRename , alterTableIfExistsRename+ , alterTableSetSchema , AlterTable (..) -- ** Constraints , addConstraint@@ -235,26 +236,64 @@ -- | `alterTableRename` changes the name of a table from the schema. ----- >>> printSQL $ alterTableRename #foo #bar+-- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ]+-- >>> :{+-- let migration :: Definition Schemas '["public" ::: '["bar" ::: 'Table ('[] :=> '[]) ] ]+-- migration = alterTableRename #foo #bar+-- in printSQL migration+-- :} -- ALTER TABLE "foo" RENAME TO "bar"; alterTableRename- :: (KnownSymbol tab0, KnownSymbol tab1)- => Alias tab0 -- ^ table to rename+ :: ( Has sch db schema+ , KnownSymbol tab1+ , Has tab0 schema ('Table table))+ => QualifiedAlias sch tab0 -- ^ table to rename -> Alias tab1 -- ^ what to rename it- -> Definition schema (Rename tab0 tab1 schema)+ -> Definition db (Alter sch (Rename tab0 tab1 schema) db ) alterTableRename tab0 tab1 = UnsafeDefinition $ "ALTER TABLE" <+> renderSQL tab0 <+> "RENAME TO" <+> renderSQL tab1 <> ";" --- | Rename a table if it exists.+-- | `alterTableIfExistsRename` changes the name of a table from the schema if it exists.+--+-- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ]+-- >>> :{+-- let migration :: Definition Schemas Schemas+-- migration = alterTableIfExistsRename #goo #gar+-- in printSQL migration+-- :}+-- ALTER TABLE IF EXISTS "goo" RENAME TO "gar"; alterTableIfExistsRename- :: (KnownSymbol tab0, KnownSymbol tab1)- => Alias tab0 -- ^ table to rename+ :: ( Has sch db schema+ , KnownSymbol tab0+ , KnownSymbol tab1 )+ => QualifiedAlias sch tab0 -- ^ table to rename -> Alias tab1 -- ^ what to rename it- -> Definition schema (RenameIfExists tab0 tab1 schema)+ -> Definition db (Alter sch (RenameIfExists tab0 tab1 schema) db ) alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $ "ALTER TABLE IF EXISTS" <+> renderSQL tab0 <+> "RENAME TO" <+> renderSQL tab1 <> ";"++{- | This form moves the table into another schema.++>>> type DB0 = '[ "sch0" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ], "sch1" ::: '[] ]+>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ] ]+>>> :{+let def :: Definition DB0 DB1+ def = alterTableSetSchema (#sch0 ! #tab) #sch1+in printSQL def+:}+ALTER TABLE "sch0"."tab" SET SCHEMA "sch1";+-}+alterTableSetSchema+ :: ( Has sch0 db schema0+ , Has tab schema0 ('Table table)+ , Has sch1 db schema1 )+ => QualifiedAlias sch0 tab -- ^ table to move+ -> Alias sch1 -- ^ where to move it+ -> Definition db (SetSchema sch0 sch1 schema0 schema1 tab 'Table table db)+alterTableSetSchema tab sch = UnsafeDefinition $+ "ALTER TABLE" <+> renderSQL tab <+> "SET SCHEMA" <+> renderSQL sch <> ";" -- | An `AlterTable` describes the alteration to perform on the columns -- of a table.
src/Squeal/PostgreSQL/Definition/Type.hs view
@@ -40,6 +40,9 @@ -- * Drop , dropType , dropTypeIfExists+ -- * Alter+ , alterTypeRename+ , alterTypeSetSchema ) where import Data.ByteString@@ -245,3 +248,44 @@ -> Definition db (Alter sch (DropSchemumIfExists td 'Typedef schema) db) dropTypeIfExists tydef = UnsafeDefinition $ "DROP TYPE IF EXISTS" <+> renderSQL tydef <> ";"++-- | `alterTypeRename` changes the name of a type from the schema.+--+-- >>> type DB = '[ "public" ::: '[ "foo" ::: 'Typedef 'PGbool ] ]+-- >>> :{+-- let def :: Definition DB '["public" ::: '["bar" ::: 'Typedef 'PGbool ] ]+-- def = alterTypeRename #foo #bar+-- in printSQL def+-- :}+-- ALTER TYPE "foo" RENAME TO "bar";+alterTypeRename+ :: ( Has sch db schema+ , KnownSymbol ty1+ , Has ty0 schema ('Typedef ty))+ => QualifiedAlias sch ty0 -- ^ type to rename+ -> Alias ty1 -- ^ what to rename it+ -> Definition db (Alter sch (Rename ty0 ty1 schema) db )+alterTypeRename ty0 ty1 = UnsafeDefinition $+ "ALTER TYPE" <+> renderSQL ty0+ <+> "RENAME TO" <+> renderSQL ty1 <> ";"++{- | This form moves the type into another schema.++>>> type DB0 = '[ "sch0" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ], "sch1" ::: '[] ]+>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ] ]+>>> :{+let def :: Definition DB0 DB1+ def = alterTypeSetSchema (#sch0 ! #ty) #sch1+in printSQL def+:}+ALTER TYPE "sch0"."ty" SET SCHEMA "sch1";+-}+alterTypeSetSchema+ :: ( Has sch0 db schema0+ , Has ty schema0 ('Typedef td)+ , Has sch1 db schema1 )+ => QualifiedAlias sch0 ty -- ^ type to move+ -> Alias sch1 -- ^ where to move it+ -> Definition db (SetSchema sch0 sch1 schema0 schema1 ty 'Typedef td db)+alterTypeSetSchema ty sch = UnsafeDefinition $+ "ALTER TYPE" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";"
src/Squeal/PostgreSQL/Definition/View.hs view
@@ -36,6 +36,9 @@ -- * Drop , dropView , dropViewIfExists+ -- * Alter+ , alterViewRename+ , alterViewSetSchema ) where import GHC.TypeLits@@ -133,3 +136,44 @@ -> Definition db (Alter sch (DropIfExists vw schema) db) dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"++-- | `alterViewRename` changes the name of a view from the schema.+--+-- >>> type DB = '[ "public" ::: '[ "foo" ::: 'View '[] ] ]+-- >>> :{+-- let def :: Definition DB '["public" ::: '["bar" ::: 'View '[] ] ]+-- def = alterViewRename #foo #bar+-- in printSQL def+-- :}+-- ALTER VIEW "foo" RENAME TO "bar";+alterViewRename+ :: ( Has sch db schema+ , KnownSymbol ty1+ , Has ty0 schema ('View vw))+ => QualifiedAlias sch ty0 -- ^ view to rename+ -> Alias ty1 -- ^ what to rename it+ -> Definition db (Alter sch (Rename ty0 ty1 schema) db )+alterViewRename vw0 vw1 = UnsafeDefinition $+ "ALTER VIEW" <+> renderSQL vw0+ <+> "RENAME TO" <+> renderSQL vw1 <> ";"++{- | This form moves the view into another schema.++>>> type DB0 = '[ "sch0" ::: '[ "vw" ::: 'View '[] ], "sch1" ::: '[] ]+>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "vw" ::: 'View '[] ] ]+>>> :{+let def :: Definition DB0 DB1+ def = alterViewSetSchema (#sch0 ! #vw) #sch1+in printSQL def+:}+ALTER VIEW "sch0"."vw" SET SCHEMA "sch1";+-}+alterViewSetSchema+ :: ( Has sch0 db schema0+ , Has vw schema0 ('View view)+ , Has sch1 db schema1 )+ => QualifiedAlias sch0 vw -- ^ view to move+ -> Alias sch1 -- ^ where to move it+ -> Definition db (SetSchema sch0 sch1 schema0 schema1 vw 'View view db)+alterViewSetSchema ty sch = UnsafeDefinition $+ "ALTER VIEW" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";"
src/Squeal/PostgreSQL/Expression.hs view
@@ -141,14 +141,7 @@ -- ^ cannot reference aliases -- | A @RankNType@ for binary operators.-type Operator x1 x2 y- = forall grp lat with db params from- . Expression grp lat with db params from x1- -- ^ left input- -> Expression grp lat with db params from x2- -- ^ right input- -> Expression grp lat with db params from y- -- ^ output+type Operator x1 x2 y = forall db. OperatorDB db x1 x2 y -- | Like `Operator` but depends on the schemas of the database type OperatorDB db x1 x2 y@@ -210,46 +203,46 @@ unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x) -instance (HasUnique tab (Join lat from) row, Has col row ty)+instance (HasUnique tab (Join from lat) row, Has col row ty) => IsLabel col (Expression 'Ungrouped lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col)-instance (HasUnique tab (Join lat from) row, Has col row ty, tys ~ '[ty])+instance (HasUnique tab (Join from lat) row, Has col row ty, tys ~ '[ty]) => IsLabel col (NP (Expression 'Ungrouped lat with db params from) tys) where fromLabel = fromLabel @col :* Nil-instance (HasUnique tab (Join lat from) row, Has col row ty, column ~ (col ::: ty))+instance (HasUnique tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) => IsLabel col (Aliased (Expression 'Ungrouped lat with db params from) column) where fromLabel = fromLabel @col `As` Alias-instance (HasUnique tab (Join lat from) row, Has col row ty, columns ~ '[col ::: ty])+instance (HasUnique tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) => IsLabel col (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where fromLabel = fromLabel @col :* Nil -instance (Has tab (Join lat from) row, Has col row ty)+instance (Has tab (Join from lat) row, Has col row ty) => IsQualified tab col (Expression 'Ungrouped lat with db params from ty) where tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col-instance (Has tab (Join lat from) row, Has col row ty, tys ~ '[ty])+instance (Has tab (Join from lat) row, Has col row ty, tys ~ '[ty]) => IsQualified tab col (NP (Expression 'Ungrouped lat with db params from) tys) where tab ! col = tab ! col :* Nil-instance (Has tab (Join lat from) row, Has col row ty, column ~ (col ::: ty))+instance (Has tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) => IsQualified tab col (Aliased (Expression 'Ungrouped lat with db params from) column) where tab ! col = tab ! col `As` col-instance (Has tab (Join lat from) row, Has col row ty, columns ~ '[col ::: ty])+instance (Has tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) => IsQualified tab col (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where tab ! col = tab ! col :* Nil instance- ( HasUnique tab (Join lat from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsLabel col (Expression ('Grouped bys) lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col) instance- ( HasUnique tab (Join lat from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty]@@ -257,7 +250,7 @@ (NP (Expression ('Grouped bys) lat with db params from) tys) where fromLabel = fromLabel @col :* Nil instance- ( HasUnique tab (Join lat from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty)@@ -265,7 +258,7 @@ (Aliased (Expression ('Grouped bys) lat with db params from) column) where fromLabel = fromLabel @col `As` Alias instance- ( HasUnique tab (Join lat from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty]@@ -274,7 +267,7 @@ fromLabel = fromLabel @col :* Nil instance- ( Has tab (Join lat from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsQualified tab col@@ -282,7 +275,7 @@ tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col instance- ( Has tab (Join lat from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty]@@ -290,7 +283,7 @@ (NP (Expression ('Grouped bys) lat with db params from) tys) where tab ! col = tab ! col :* Nil instance- ( Has tab (Join lat from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty)@@ -298,7 +291,7 @@ (Aliased (Expression ('Grouped bys) lat with db params from) column) where tab ! col = tab ! col `As` col instance- ( Has tab (Join lat from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty]
src/Squeal/PostgreSQL/Expression/Aggregate.hs view
@@ -28,6 +28,7 @@ module Squeal.PostgreSQL.Expression.Aggregate ( -- * Aggregate Aggregate (..)+ -- * Aggregate Arguments , AggregateArg (..) , pattern All , pattern Alls@@ -416,11 +417,17 @@ = AggregateAll { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from]- , aggregateFilter :: [Condition 'Ungrouped lat with db params from] }+ -- ^ `orderBy`+ , aggregateFilter :: [Condition 'Ungrouped lat with db params from]+ -- ^ `filterWhere`+ } | AggregateDistinct { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from]- , aggregateFilter :: [Condition 'Ungrouped lat with db params from] }+ -- ^ `orderBy`+ , aggregateFilter :: [Condition 'Ungrouped lat with db params from]+ -- ^ `filterWhere`+ } instance SOP.SListI xs => RenderSQL (AggregateArg xs lat with db params from) where renderSQL = \case@@ -447,6 +454,7 @@ -- argument once for each input row. pattern All :: Expression 'Ungrouped lat with db params from x+ -- ^ argument -> AggregateArg '[x] lat with db params from pattern All x = Alls (x :* Nil) @@ -454,6 +462,7 @@ -- arguments once for each input row. pattern Alls :: NP (Expression 'Ungrouped lat with db params from) xs+ -- ^ arguments -> AggregateArg xs lat with db params from pattern Alls xs = AggregateAll xs [] [] @@ -462,6 +471,7 @@ -- is not null allNotNull :: Expression 'Ungrouped lat with db params from ('Null x)+ -- ^ argument -> AggregateArg '[ 'NotNull x] lat with db params from allNotNull x = All (unsafeNotNull x) & filterWhere (not_ (isNull x)) @@ -471,6 +481,7 @@ -} pattern Distinct :: Expression 'Ungrouped lat with db params from x+ -- ^ argument -> AggregateArg '[x] lat with db params from pattern Distinct x = Distincts (x :* Nil) @@ -480,6 +491,7 @@ -} pattern Distincts :: NP (Expression 'Ungrouped lat with db params from) xs+ -- ^ arguments -> AggregateArg xs lat with db params from pattern Distincts xs = AggregateDistinct xs [] [] @@ -489,6 +501,7 @@ -} distinctNotNull :: Expression 'Ungrouped lat with db params from ('Null x)+ -- ^ argument -> AggregateArg '[ 'NotNull x] lat with db params from distinctNotNull x = Distinct (unsafeNotNull x) & filterWhere (not_ (isNull x)) @@ -502,6 +515,7 @@ -} filterWhere :: Condition grp lat with db params from+ -- ^ include rows which evaluate to true -> arg xs lat with db params from -> arg xs lat with db params from instance FilterWhere AggregateArg 'Ungrouped where
src/Squeal/PostgreSQL/Expression/Array.hs view
@@ -32,15 +32,21 @@ , array2 , cardinality , index+ , index1+ , index2 , unnest+ , arrAny+ , arrAll ) where import Data.String import Data.Word (Word64)+import GHC.TypeNats import qualified Generics.SOP as SOP import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Expression.Type import Squeal.PostgreSQL.Query.From.Set import Squeal.PostgreSQL.Render@@ -133,12 +139,104 @@ index :: Word64 -- ^ index -> null ('PGvararray ty) --> NullifyType ty-index n expr = UnsafeExpression $- parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"+index i arr = UnsafeExpression $+ parenthesized (renderSQL arr) <> "[" <> fromString (show i) <> "]" +-- | Typesafe indexing of fixed length arrays.+--+-- >>> printSQL $ array1 (true *: false) & index1 @1+-- (ARRAY[TRUE, FALSE])[1]+index1+ :: forall i n ty+ . (1 <= i, i <= n, KnownNat i)+ => 'NotNull ('PGfixarray '[n] ty) --> ty+ -- ^ vector index+index1 arr = UnsafeExpression $+ parenthesized (renderSQL arr)+ <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]"++-- | Typesafe indexing of fixed size matrices.+--+-- >>> printSQL $ array2 ((true *: false) *: (false *: true)) & index2 @1 @2+-- (ARRAY[[TRUE, FALSE], [FALSE, TRUE]])[1][2]+index2+ :: forall i j m n ty+ . ( 1 <= i, i <= m, KnownNat i+ , 1 <= j, j <= n, KnownNat j+ )+ => 'NotNull ('PGfixarray '[m,n] ty) --> ty+ -- ^ matrix index+index2 arr = UnsafeExpression $+ parenthesized (renderSQL arr)+ <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]"+ <> "[" <> fromString (show (natVal (SOP.Proxy @j))) <> "]"+ -- | Expand an array to a set of rows -- -- >>> printSQL $ unnest (array [null_, false, true]) -- unnest(ARRAY[NULL, FALSE, TRUE]) unnest :: null ('PGvararray ty) -|-> ("unnest" ::: '["unnest" ::: ty]) unnest = unsafeSetFunction "unnest"++{- |+The right-hand side is a parenthesized expression,+which must yield an array value. The left-hand expression+is evaluated and compared to each element of the array using+the given `Operator`, which must yield a Boolean result.+The result of `arrAll` is `true` if all comparisons yield true+(including the case where the array has zero elements).+The result is `false` if any false result is found.++If the array expression yields a null array,+the result of `arrAll` will be null. If the left-hand expression yields null,+the result of `arrAll` is ordinarily null+(though a non-strict comparison `Operator`+could possibly yield a different result).+Also, if the right-hand array contains any null+elements and no false comparison result is obtained,+the result of `arrAll` will be null, not true+(again, assuming a strict comparison `Operator`).+This is in accordance with SQL's normal rules for Boolean+combinations of null values.++>>> printSQL $ arrAll true (.==) (array [true, false, null_])+(TRUE = ALL (ARRAY[TRUE, FALSE, NULL]))+>>> printSQL $ arrAll "hi" like (array ["bi","hi"])+((E'hi' :: text) LIKE ALL (ARRAY[(E'bi' :: text), (E'hi' :: text)]))+-}+arrAll+ :: Expression grp lat with db params from ty1 -- ^ expression+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator+ -> Expression grp lat with db params from ('Null ('PGvararray ty2)) -- ^ array+ -> Condition grp lat with db params from+arrAll x (?) xs = x ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL xs))++{- |+The right-hand side is a parenthesized expression, which must yield an array+value. The left-hand expression is evaluated and compared to each element of+the array using the given `Operator`, which must yield a Boolean result. The+result of `arrAny` is `true` if any true result is obtained. The result is+`false` if no true result is found (including the case where the array+has zero elements).++If the array expression yields a null array, the result of `arrAny` will+be null. If the left-hand expression yields null, the result of `arrAny` is+ordinarily null (though a non-strict comparison `Operator` could possibly+yield a different result). Also, if the right-hand array contains any+null elements and no true comparison result is obtained, the result of+`arrAny` will be null, not false+(again, assuming a strict comparison `Operator`).+This is in accordance with SQL's normal rules for+Boolean combinations of null values.++>>> printSQL $ arrAny true (.==) (array [true, false, null_])+(TRUE = ANY (ARRAY[TRUE, FALSE, NULL]))+>>> printSQL $ arrAny "hi" like (array ["bi","hi"])+((E'hi' :: text) LIKE ANY (ARRAY[(E'bi' :: text), (E'hi' :: text)]))+-}+arrAny+ :: Expression grp lat with db params from ty1 -- ^ expression+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator+ -> Expression grp lat with db params from ('Null ('PGvararray ty2)) -- ^ array+ -> Condition grp lat with db params from+arrAny x (?) xs = x ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL xs))
src/Squeal/PostgreSQL/Expression/Comparison.hs view
@@ -92,7 +92,7 @@ (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> let expr = greatest [param @1] currentTimestamp :: Expression grp lat with db '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)+-- | >>> let expr = greatest [param @1] currentTimestamp -- >>> printSQL expr -- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP) greatest :: FunctionVar ty ty ty
src/Squeal/PostgreSQL/Expression/Inline.hs view
@@ -45,9 +45,9 @@ import Data.String import Data.Text (Text) import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, UTCTime)-import Data.Time.Format (formatTime, defaultTimeLocale)-import Data.Time.Calendar (Day, toGregorian)-import Data.Time.LocalTime (LocalTime(LocalTime), TimeOfDay(TimeOfDay), TimeZone)+import Data.Time.Format.ISO8601 (formatShow, timeOfDayAndOffsetFormat, FormatExtension(ExtendedFormat), iso8601Show)+import Data.Time.Calendar (Day)+import Data.Time.LocalTime (LocalTime, TimeOfDay, TimeZone) import Data.UUID.Types (UUID, toASCIIBytes) import Data.Vector (Vector, toList) import Database.PostgreSQL.LibPQ (Oid(Oid))@@ -179,35 +179,40 @@ interval_ (fromIntegral secs) Seconds +! interval_ (fromIntegral microsecs) Microseconds instance Inline Day where- inline day =- let (y,m,d) = toGregorian day- in inferredtype $ makeDate (fromInteger y :* fromIntegral m *: fromIntegral d)+ inline+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show instance Inline UTCTime where inline = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString- . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q%z"+ . iso8601Show instance Inline (TimeOfDay, TimeZone) where- inline (hms, tz)+ inline = inferredtype . UnsafeExpression . singleQuotedUtf8 . fromString- $ formatTime defaultTimeLocale "%H:%M:%S" hms- <> formatTime defaultTimeLocale "%z" tz+ . formatShow (timeOfDayAndOffsetFormat ExtendedFormat) instance Inline TimeOfDay where- inline (TimeOfDay hr mn sc) = inferredtype $ makeTime- (fromIntegral hr :* fromIntegral mn *: fromRational (toRational sc))+ inline+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show instance Inline LocalTime where- inline (LocalTime day t) =- let- (y,m,d) = toGregorian day- TimeOfDay hr mn sc = t- in inferredtype $ makeTimestamp- ( fromInteger y :* fromIntegral m :* fromIntegral d- :* fromIntegral hr :* fromIntegral mn *: fromRational (toRational sc) )+ inline+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show instance Inline (Range Int32) where inline = range int4range . fmap inline instance Inline (Range Int64) where@@ -290,7 +295,7 @@ => InlineField (alias ::: x) (alias ::: ty) where inlineField (SOP.P x) = inlineParam x `as` Alias @alias --- | Use a Haskell record as a inline a row of expressions.+-- | Inline a Haskell record as a row of expressions. inlineFields :: ( SOP.IsRecord hask fields , SOP.AllZip InlineField fields row )@@ -320,7 +325,7 @@ Default -> Default `as` (Alias @col) Set (SOP.I x) -> Set (inlineParam x) `as` (Alias @col) --- | Use a Haskell record as a inline list of columns+-- | Inline a Haskell record as a list of columns. inlineColumns :: ( SOP.IsRecord hask xs , SOP.AllZip InlineColumn xs columns )
src/Squeal/PostgreSQL/Expression/Null.hs view
@@ -63,6 +63,7 @@ -- nullity as `NotNull`. monoNotNull :: (forall null. Expression grp lat with db params from (null ty))+ -- ^ null polymorphic -> Expression grp lat with db params from ('NotNull ty) monoNotNull = id @@ -114,9 +115,8 @@ {-| right inverse to `fromNull`, if its arguments are equal then `nullIf` gives @NULL@. ->>> :set -XTypeApplications -XDataKinds->>> let expr = nullIf (false *: param @1) :: Expression grp lat with db '[ 'NotNull 'PGbool] from ('Null 'PGbool)->>> printSQL expr+>>> :set -XTypeApplications+>>> printSQL (nullIf (false *: param @1)) NULLIF(FALSE, ($1 :: bool)) -} nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
src/Squeal/PostgreSQL/Expression/Parameter.hs view
@@ -14,6 +14,7 @@ , FlexibleContexts , FlexibleInstances , FunctionalDependencies+ , GADTs , KindSignatures , MultiParamTypeClasses , OverloadedStrings@@ -55,8 +56,7 @@ | n params -> ty where -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. --- -- >>> let expr = parameter @1 int4 :: Expression lat '[] grp db '[ 'Null 'PGint4] from ('Null 'PGint4)- -- >>> printSQL expr+ -- >>> printSQL (parameter @1 int4) -- ($1 :: int4) parameter :: TypeExpression db ty@@ -64,15 +64,15 @@ parameter ty = UnsafeExpression $ parenthesized $ "$" <> renderNat @n <+> "::" <+> renderSQL ty-instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1-instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)- => HasParameter n (ty' : params) ty+instance {-# OVERLAPPING #-} params ~ (x ': xs) => HasParameter 1 params x+instance {-# OVERLAPPABLE #-}+ (KnownNat n, HasParameter (n-1) xs x, params ~ (y ': xs))+ => HasParameter n params x -- | `param` takes a `Nat` using type application and for basic types, -- infers a `TypeExpression`. ----- >>> let expr = param @1 :: Expression grp lat with db '[ 'Null 'PGint4] from ('Null 'PGint4)--- >>> printSQL expr+-- >>> printSQL (param @1 @('Null 'PGint4)) -- ($1 :: int4) param :: forall n ty lat with db params from grp
src/Squeal/PostgreSQL/Expression/Range.hs view
@@ -152,7 +152,7 @@ -- | contains range (@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)-(@>.) = unsafeBinaryOp "<@"+(@>.) = unsafeBinaryOp "@>" -- | strictly left of, -- return false when an empty range is involved
src/Squeal/PostgreSQL/Expression/Type.hs view
@@ -359,6 +359,7 @@ instance PGTyped db 'PGtimetz where pgtype = timeWithTimeZone instance PGTyped db 'PGinterval where pgtype = interval instance PGTyped db 'PGuuid where pgtype = uuid+instance PGTyped db 'PGinet where pgtype = inet instance PGTyped db 'PGjson where pgtype = json instance PGTyped db 'PGjsonb where pgtype = jsonb instance PGTyped db pg => PGTyped db ('PGvararray (null pg)) where
src/Squeal/PostgreSQL/Expression/Window.hs view
@@ -118,7 +118,7 @@ orderBy sortsR (WindowDefinition parts sortsL) = WindowDefinition parts (sortsL ++ sortsR) -instance RenderSQL (WindowDefinition lat with db from grp params) where+instance RenderSQL (WindowDefinition grp lat with db params from) where renderSQL (WindowDefinition part ord) = renderPartitionByClause part <> renderSQL ord where@@ -173,7 +173,9 @@ (from :: FromType) = WindowArg { windowArgs :: NP (Expression grp lat with db params from) args+ -- ^ `Window` or `Windows` , windowFilter :: [Condition grp lat with db params from]+ -- ^ `filterWhere` } deriving stock (GHC.Generic) instance SOP.SListI args@@ -193,12 +195,14 @@ -- | `Window` invokes a `WindowFunction` on a single argument. pattern Window :: Expression grp lat with db params from arg+ -- ^ argument -> WindowArg grp '[arg] lat with db params from pattern Window x = Windows (x :* Nil) -- | `Windows` invokes a `WindowFunction` on multiple argument. pattern Windows :: NP (Expression grp lat with db params from) args+ -- ^ arguments -> WindowArg grp args lat with db params from pattern Windows xs = WindowArg xs []
src/Squeal/PostgreSQL/Manipulation.hs view
@@ -31,11 +31,12 @@ module Squeal.PostgreSQL.Manipulation ( -- * Manipulation- Manipulation_- , Manipulation (..)+ Manipulation (..)+ , Manipulation_ , queryStatement , ReturningClause (..) , pattern Returning_+ , UsingClause (..) ) where import Control.DeepSeq@@ -52,6 +53,7 @@ import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Query.From import Squeal.PostgreSQL.Query.Select import Squeal.PostgreSQL.Query.With import Squeal.PostgreSQL.Type.Schema@@ -63,58 +65,20 @@ {- | A `Manipulation` is a statement which may modify data in the database,-but does not alter its schemas. Examples are inserts, updates and deletes.-A `Query` is also considered a `Manipulation` even though it does not modify data.+but does not alter its schemas. Examples are+`Squeal.PostgreSQL.Manipulation.Insert.insertInto`s,+`Squeal.PostgreSQL.Manipulation.Update.update`s and+`Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`s.+A `queryStatement` is also considered a `Manipulation` even though it does not modify data. The general `Manipulation` type is parameterized by * @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions, * @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s, * @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,-* @row :: RowType@ - return type of the `Query`.--}-newtype Manipulation- (with :: FromType)- (db :: SchemasType)- (params :: [NullType])- (columns :: RowType)- = UnsafeManipulation { renderManipulation :: ByteString }- deriving stock (GHC.Generic,Show,Eq,Ord)- deriving newtype (NFData)-instance RenderSQL (Manipulation with db params columns) where- renderSQL = renderManipulation-instance With Manipulation where- with Done manip = manip- with ctes manip = UnsafeManipulation $- "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL manip--{- |-The top level `Manipulation_` type is parameterized by a @db@ `SchemasType`,-against which the query is type-checked, an input @params@ Haskell `Type`,-and an ouput row Haskell `Type`.--`Manipulation_` is a type family which resolves into a `Manipulation`,-so don't be fooled by the input params and output row Haskell `Type`s,-which are converted into appropriate-Postgres @[@`NullType`@]@ params and `RowType` rows.-Use a top-level `Squeal.PostgreSQL.Session.Statement.Statement` to-fix actual Haskell input params and output rows.--A top-level `Manipulation_` can be run-using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@-using `Squeal.PostgreSQL.Session.manipulate`.--Generally, @params@ will be a Haskell tuple or record whose entries-may be referenced using positional-`Squeal.PostgreSQL.Expression.Parameter.param`s and @row@ will be a-Haskell record, whose entries will be targeted using overloaded labels.+* @row :: RowType@ - return type of the `Manipulation`. ->>> :set -XDeriveAnyClass -XDerivingStrategies->>> :{-data Row a b = Row { col1 :: a, col2 :: b }- deriving stock (GHC.Generic)- deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)-:}+Let's see some examples of `Manipulation`s. simple insert: @@ -122,12 +86,12 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- manipulation :: Manipulation_ (Public Schema) () ()- manipulation =+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))-in printSQL manipulation+in printSQL manp :}-INSERT INTO "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT)+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) out-of-line parameterized insert: @@ -135,41 +99,45 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- manipulation :: Manipulation_ (Public Schema) (Only Int32) ()- manipulation =+ manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[]+ manp = insertInto_ #tab $ Values_ (Default `as` #col1 :* Set (param @1) `as` #col2)-in printSQL manipulation+in printSQL manp :}-INSERT INTO "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4))+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4)) in-line parameterized insert: >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{+data Row = Row { col1 :: Optional SOP.I ('Def :=> Int32), col2 :: Int32 }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :{ let- manipulation- :: Manipulation_ (Public Schema) () ()- manipulation =- insertInto_ #tab $ inlineValues- (Row {col1 = Default , col2 = 2 :: Int32})- [Row {col1 = NotDefault (3 :: Int32), col2 = 4 :: Int32}]-in printSQL manipulation+ manp :: Row -> Row -> Manipulation with (Public Schema) '[] '[]+ manp row1 row2 = insertInto_ #tab $ inlineValues row1 [row2]+ row1 = Row {col1 = Default, col2 = 2 :: Int32}+ row2 = Row {col1 = NotDefault (3 :: Int32), col2 = 4 :: Int32}+in printSQL (manp row1 row2) :}-INSERT INTO "tab" ("col1", "col2") VALUES (DEFAULT, (2 :: int4)), ((3 :: int4), (4 :: int4))+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, (2 :: int4)), ((3 :: int4), (4 :: int4)) returning insert: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () (Only Int32)- manipulation =+ manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4]+ manp = insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))- OnConflictDoRaise (Returning (#col1 `as` #fromOnly))-in printSQL manipulation+ OnConflictDoRaise (Returning #col1)+in printSQL manp :}-INSERT INTO "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "fromOnly"+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "col1" upsert: @@ -178,46 +146,46 @@ >>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] >>> :{ let- manipulation :: Manipulation_ (Public CustomersSchema) () ()- manipulation =+ manp :: Manipulation with (Public CustomersSchema) '[] '[]+ manp = insertInto #customers (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email)) (OnConflict (OnConstraint #uq) (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) [])) (Returning_ Nil)-in printSQL manipulation+in printSQL manp :}-INSERT INTO "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email"))+INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) query insert: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () ()- manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = insertInto_ #tab (Subquery (select Star (from (table #tab))))+in printSQL manp :}-INSERT INTO "tab" SELECT * FROM "tab" AS "tab"+INSERT INTO "tab" AS "tab" SELECT * FROM "tab" AS "tab" update: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () ()- manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)+in printSQL manp :}-UPDATE "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2")+UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") delete: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)- manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ manp = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)+in printSQL manp :}-DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *+DELETE FROM "tab" AS "tab" WHERE ("col1" = "col2") RETURNING * delete and using clause: @@ -230,15 +198,15 @@ >>> :{ let- manipulation :: Manipulation_ (Public Schema3) () ()- manipulation =+ manp :: Manipulation with (Public Schema3) '[] '[]+ manp = deleteFrom #tab (Using (table #other_tab & also (table #third_tab))) ( (#tab ! #col2 .== #other_tab ! #col2) .&& (#tab ! #col2 .== #third_tab ! #col2) ) (Returning_ Nil)-in printSQL manipulation+in printSQL manp :}-DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))+DELETE FROM "tab" AS "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2")) with manipulation: @@ -246,14 +214,81 @@ >>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)] >>> :{ let- manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()- manipulation = with+ manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]+ manp = with (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del) (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))-in printSQL manipulation+in printSQL manp :}-WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"+WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del" -}+newtype Manipulation+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (columns :: RowType)+ = UnsafeManipulation { renderManipulation :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (Manipulation with db params columns) where+ renderSQL = renderManipulation+instance With Manipulation where+ with Done manip = manip+ with ctes manip = UnsafeManipulation $+ "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL manip++{- |+The `Manipulation_` type is parameterized by a @db@ `SchemasType`,+against which it is type-checked, an input @params@ Haskell `Type`,+and an ouput row Haskell `Type`.++Generally, @params@ will be a Haskell tuple or record whose entries+may be referenced using positional+`Squeal.PostgreSQL.Expression.Parameter.param`s and @row@ will be a+Haskell record, whose entries will be targeted using overloaded labels.++A `Manipulation_` can be run+using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@+using `Squeal.PostgreSQL.Session.manipulate`.++`Manipulation_` is a type family which resolves into a `Manipulation`,+so don't be fooled by the input params and output row Haskell `Type`s,+which are converted into appropriate+Postgres @[@`NullType`@]@ params and `RowType` rows.+Use `Squeal.PostgreSQL.Session.Statement.manipulation` to+fix actual Haskell input params and output rows.++>>> :set -XDeriveAnyClass -XDerivingStrategies+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+data Row = Row { col1 :: Maybe Int64, col2 :: String }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :{+let+ manp :: Manipulation_ (Public Schema) (Int64, Int64) Row+ manp = deleteFrom #tab NoUsing (#col1 .== param @1 + param @2) (Returning Star)+ stmt :: Statement (Public Schema) (Int64, Int64) Row+ stmt = manipulation manp+:}++>>> :type manp+manp+ :: Manipulation+ '[]+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ '[ 'NotNull 'PGint8, 'NotNull 'PGint8]+ '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext]+>>> :type stmt+stmt+ :: Statement+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ (Int64, Int64)+ Row+-} type family Manipulation_ (db :: SchemasType) (params :: Type) (row :: Type) where Manipulation_ db params row = Manipulation '[] db (TuplePG params) (RowPG row) @@ -264,7 +299,7 @@ -> Manipulation with db params columns queryStatement q = UnsafeManipulation $ renderSQL q --- | A `ReturningClause` computes and return value(s) based+-- | A `ReturningClause` computes and returns value(s) based -- on each row actually inserted, updated or deleted. This is primarily -- useful for obtaining values that were supplied by defaults, such as a -- serial sequence number. However, any expression using the table's columns@@ -273,7 +308,7 @@ -- but not updated because an `Squeal.PostgreSQL.Manipulation.Insert.OnConflict` -- `Squeal.PostgreSQL.Manipulation.Insert.DoUpdate` condition was not satisfied, -- the row will not be returned. `Returning` `Star` will return all columns--- in the row. Use `Returning` `Nil` in the common case where no return+-- in the row. Use `Returning_` `Nil` in the common case where no return -- values are desired. newtype ReturningClause with db params from row = Returning (Selection 'Ungrouped '[] with db params from row)@@ -290,3 +325,19 @@ -- ^ row of values -> ReturningClause with db params from row pattern Returning_ list = Returning (List list)++-- | Specify additional tables with `Using`+-- an `also` list of table expressions, allowing columns+-- from other tables to appear in the WHERE condition.+-- This is similar to the list of tables that can be specified+-- in the FROM Clause of a SELECT statement;+-- for example, an alias for the table name can be specified.+-- Do not repeat the target table in the `Using` list,+-- unless you wish to set up a self-join.+-- `NoUsing` if no additional tables are to be used.+data UsingClause with db params from where+ NoUsing :: UsingClause with db params '[]+ Using+ :: FromClause '[] with db params from+ -- ^ what to use+ -> UsingClause with db params from
+ src/Squeal/PostgreSQL/Manipulation/Call.hs view
@@ -0,0 +1,117 @@+{-|+Module: Squeal.PostgreSQL.Call+Description: call statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++call statements+-}++{-# LANGUAGE+ DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PatternSynonyms+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Manipulation.Call+ ( -- * Call+ call+ , unsafeCall+ , callN+ , unsafeCallN+ ) where++import Data.ByteString hiding (foldr)++import Generics.SOP (SListI)++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- |+>>> printSQL $ unsafeCall "p" true+CALL p(TRUE)+-}+unsafeCall+ :: ByteString -- ^ procedure to call+ -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments+ -> Manipulation with db params '[]+unsafeCall pro x = UnsafeManipulation $+ "CALL" <+> pro <> parenthesized (renderSQL x)++{- | Call a user defined procedure of one variable.++>>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4 ] ]+>>> :{+let+ p :: Manipulation '[] (Public Schema) '[] '[]+ p = call #p 1+in+ printSQL p+:}+CALL "p"((1 :: int4))+-}+call+ :: ( Has sch db schema+ , Has pro schema ('Procedure '[x]) )+ => QualifiedAlias sch pro -- ^ procedure to call+ -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments+ -> Manipulation with db params '[]+call = unsafeCall . renderSQL+++{- |+>>> printSQL $ unsafeCallN "p" (true *: false)+CALL p(TRUE, FALSE)+-}+unsafeCallN+ :: SListI xs+ => ByteString -- ^ procedure to call+ -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments+ -> Manipulation with db params '[]+unsafeCallN pro xs = UnsafeManipulation $ + "CALL" <+> pro <> parenthesized (renderCommaSeparated renderSQL xs)++{- | Call a user defined procedure.++>>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] ]+>>> :{+let+ p :: Manipulation '[] (Public Schema) '[] '[]+ p = callN #p (1 *: "hi")+in+ printSQL p+:}+CALL "p"((1 :: int4), (E'hi' :: text))+-}+callN+ :: ( Has sch db schema+ , Has pro schema ('Procedure xs)+ , SListI xs )+ => QualifiedAlias sch pro -- ^ procedure to call+ -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments+ -> Manipulation with db params '[]+callN = unsafeCallN . renderSQL
src/Squeal/PostgreSQL/Manipulation/Delete.hs view
@@ -33,7 +33,6 @@ ( -- * Delete deleteFrom , deleteFrom_- , UsingClause (..) ) where import qualified Generics.SOP as SOP@@ -43,7 +42,6 @@ import Squeal.PostgreSQL.Manipulation import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Query.From import Squeal.PostgreSQL.Type.Schema -- $setup@@ -53,48 +51,54 @@ DELETE statements -----------------------------------------} --- | Specify additional tables with `Using`--- an `also` list of table expressions, allowing columns--- from other tables to appear in the WHERE condition.--- This is similar to the list of tables that can be specified--- in the FROM Clause of a SELECT statement;--- for example, an alias for the table name can be specified.--- Do not repeat the target table in the `Using` list,--- unless you wish to set up a self-join.--- `NoUsing` if no additional tables are to be used.-data UsingClause with db params from where- NoUsing :: UsingClause with db params '[]- Using- :: FromClause '[] with db params from- -- ^ what to use- -> UsingClause with db params from+{- | Delete rows from a table. --- | Delete rows from a table.+>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ manp = deleteFrom #tab1 (Using (table #tab2)) (#tab1 ! #col1 .== #tab2 ! #col2) (Returning (#tab1 & DotStar))+in printSQL manp+:}+DELETE FROM "tab1" AS "tab1" USING "tab2" AS "tab2" WHERE ("tab1"."col1" = "tab2"."col2") RETURNING "tab1".*+-} deleteFrom :: ( SOP.SListI row , Has sch db schema- , Has tab schema ('Table table) )- => QualifiedAlias sch tab -- ^ table to delete from+ , Has tab0 schema ('Table table) )+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from -> UsingClause with db params from -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from) -- ^ condition under which to delete a row- -> ReturningClause with db params '[tab ::: TableToRow table] row+ -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return -> Manipulation with db params row-deleteFrom tab using wh returning = UnsafeManipulation $+deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $ "DELETE FROM"- <+> renderSQL tab+ <+> renderSQL tab0 <+> "AS" <+> renderSQL tab <> case using of NoUsing -> "" Using tables -> " USING" <+> renderSQL tables <+> "WHERE" <+> renderSQL wh <> renderSQL returning --- | Delete rows returning `Nil`.+{- | Delete rows returning `Nil`.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[]+ manp = deleteFrom_ (#tab `as` #t) (#t ! #col1 .== param @1)+in printSQL manp+:}+DELETE FROM "tab" AS "t" WHERE ("t"."col1" = ($1 :: int4))+-} deleteFrom_ :: ( Has sch db schema- , Has tab schema ('Table table) )- => QualifiedAlias sch tab -- ^ table to delete from+ , Has tab0 schema ('Table table) )+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] -- ^ condition under which to delete a row -> Manipulation with db params '[]
src/Squeal/PostgreSQL/Manipulation/Insert.hs view
@@ -73,13 +73,29 @@ conceptually inserted one row at a time. Of course you can also insert more than one row, but there is no way to insert less than one row. Even if you know only some column values, a complete row must be created.++>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]+>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]+>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]+>>> :{+let+ manp :: Manipulation with (Public CustomersSchema) '[] '[]+ manp =+ insertInto #customers+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))+ (OnConflict (OnConstraint #uq)+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))+ (Returning_ Nil)+in printSQL manp+:}+INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) -} insertInto :: ( Has sch db schema- , Has tab schema ('Table table)+ , Has tab0 schema ('Table table) , SOP.SListI (TableToColumns table) , SOP.SListI row )- => QualifiedAlias sch tab+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table -> QueryClause with db params (TableToColumns table) -- ^ what to insert@@ -88,18 +104,31 @@ -> ReturningClause with db params '[tab ::: TableToRow table] row -- ^ what to return -> Manipulation with db params row-insertInto tab qry conflict ret = UnsafeManipulation $- "INSERT" <+> "INTO" <+> renderSQL tab+insertInto (tab0 `As` tab) qry conflict ret = UnsafeManipulation $+ "INSERT" <+> "INTO"+ <+> renderSQL tab0 <+> "AS" <+> renderSQL tab <+> renderSQL qry <> renderSQL conflict <> renderSQL ret --- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.+{- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.++>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[] '[]+ manp =+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))+in printSQL manp+:}+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT)+-} insertInto_ :: ( Has sch db schema- , Has tab schema ('Table table)+ , Has tab0 schema ('Table table) , SOP.SListI (TableToColumns table) )- => QualifiedAlias sch tab+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table -> QueryClause with db params (TableToColumns table) -- ^ what to insert@@ -111,9 +140,9 @@ data QueryClause with db params columns where Values :: SOP.SListI columns- => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns+ => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns -- ^ row of values- -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns]+ -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns] -- ^ additional rows of values -> QueryClause with db params columns Select@@ -163,7 +192,7 @@ -- whose `ColumnsType` must match the tables'. pattern Values_ :: SOP.SListI columns- => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns+ => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns -- ^ row of values -> QueryClause with db params columns pattern Values_ vals = Values vals []
src/Squeal/PostgreSQL/Manipulation/Update.hs view
@@ -36,6 +36,7 @@ ) where import Data.ByteString hiding (foldr)+import GHC.TypeLits import qualified Generics.SOP as SOP @@ -61,37 +62,73 @@ UPDATE statements -----------------------------------------} --- | An `update` command changes the values of the specified columns--- in all rows that satisfy the condition.+{- | An `update` command changes the values of the specified columns+in all rows that satisfy the condition.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[]+ '["col1" ::: 'NotNull 'PGint4,+ "col2" ::: 'NotNull 'PGint4]+ manp = update+ (#tab1 `as` #t1)+ (Set (2 + #t2 ! #col2) `as` #col1)+ (Using (table (#tab2 `as` #t2)))+ (#t1 ! #col1 ./= #t2 ! #col2)+ (Returning (#t1 & DotStar))+in printSQL manp+:}+UPDATE "tab1" AS "t1" SET "col1" = ((2 :: int4) + "t2"."col2") FROM "tab2" AS "t2" WHERE ("t1"."col1" <> "t2"."col2") RETURNING "t1".*+-} update :: ( Has sch db schema- , Has tab schema ('Table table)+ , Has tab0 schema ('Table table) , Updatable table updates , SOP.SListI row )- => QualifiedAlias sch tab -- ^ table to update- -> NP (Aliased (Optional (Expression 'Ungrouped '[] '[] db params '[tab ::: TableToRow table]))) updates- -- ^ modified values to replace old values- -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table]- -- ^ condition under which to perform update on a row- -> ReturningClause with db params '[tab ::: TableToRow table] row -- ^ results to return+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update+ -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)))) updates+ -- ^ update expressions, modified values to replace old values+ -> UsingClause with db params from+ -- ^ FROM A table expression allowing columns from other tables to appear+ -- in the WHERE condition and update expressions.+ -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)+ -- ^ WHERE condition under which to perform update on a row+ -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return -> Manipulation with db params row-update tab columns wh returning = UnsafeManipulation $+update (tab0 `As` tab) columns using wh returning = UnsafeManipulation $ "UPDATE"- <+> renderSQL tab+ <+> renderSQL tab0 <+> "AS" <+> renderSQL tab <+> "SET" <+> renderCommaSeparated renderUpdate columns+ <> case using of+ NoUsing -> ""+ Using tables -> " FROM" <+> renderSQL tables <+> "WHERE" <+> renderSQL wh <> renderSQL returning --- | Update a row returning `Nil`.+{- | Update a row returning `Nil`.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)+in printSQL manp+:}+UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2")+-} update_ :: ( Has sch db schema- , Has tab schema ('Table table)+ , Has tab0 schema ('Table table)+ , KnownSymbol tab , Updatable table updates )- => QualifiedAlias sch tab -- ^ table to update- -> NP (Aliased (Optional (Expression 'Ungrouped '[] '[] db params '[tab ::: TableToRow table]))) updates+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update+ -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[tab ::: TableToRow table]))) updates -- ^ modified values to replace old values -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table] -- ^ condition under which to perform update on a row -> Manipulation with db params '[]-update_ tab columns wh = update tab columns wh (Returning_ Nil)+update_ tab columns wh = update tab columns NoUsing wh (Returning_ Nil)
src/Squeal/PostgreSQL/Query.hs view
@@ -33,8 +33,8 @@ module Squeal.PostgreSQL.Query ( -- * Query- Query_- , Query (..)+ Query (..)+ , Query_ -- ** Set Operations , union , unionAll@@ -67,52 +67,13 @@ The general `Query` type is parameterized by -+* @lat :: FromType@ - scope for `Squeal.PostgreSQL.Query.From.Join.JoinLateral` and subquery expressions, * @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions, * @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s, * @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, * @row :: RowType@ - return type of the `Query`.--}-newtype Query- (lat :: FromType)- (with :: FromType)- (db :: SchemasType)- (params :: [NullType])- (row :: RowType)- = UnsafeQuery { renderQuery :: ByteString }- deriving stock (GHC.Generic,Show,Eq,Ord)- deriving newtype (NFData)-instance RenderSQL (Query lat with db params row) where renderSQL = renderQuery -{- |-The top level `Query_` type is parameterized by a @db@ `SchemasType`,-against which the query is type-checked, an input @params@ Haskell `Type`,-and an ouput row Haskell `Type`.--`Query_` is a type family which resolves into a `Query`,-so don't be fooled by the input params and output row Haskell `Type`s,-which are converted into appropriate-Postgres @[@`NullType`@]@ params and `RowType` rows.-Use a top-level `Squeal.PostgreSQL.Session.Statement.Statement` to-fix actual Haskell input params and output rows.--A top-level `Query_` can be run-using `Squeal.PostgreSQL.Session.runQueryParams`, or if @params = ()@-using `Squeal.PostgreSQL.Session.runQuery`.--Generally, @params@ will be a Haskell tuple or record whose entries-may be referenced using positional-`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a-Haskell record, whose entries will be targeted using overloaded labels.--Let's see some examples of queries.-->>> :set -XDeriveAnyClass -XDerivingStrategies->>> :{-data Row a b = Row { col1 :: a, col2 :: b }- deriving stock (GHC.Generic)- deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)-:}+Let's see some `Query` examples. simple query: @@ -120,9 +81,9 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab))-in printSQL query+ qry :: Query lat with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab))+in printSQL qry :} SELECT * FROM "tab" AS "tab" @@ -130,13 +91,13 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query =+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2) ( from (table #tab) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) )-in printSQL query+in printSQL qry :} SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > (0 :: int4))) @@ -144,9 +105,9 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))-in printSQL query+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))+in printSQL qry :} SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub" @@ -154,9 +115,9 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)-in printSQL query+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)+in printSQL qry :} SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4 @@ -164,9 +125,9 @@ >>> :{ let- query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)- query = select Star (from (table #tab) & where_ (#col1 .> param @1))-in printSQL query+ qry :: Query '[] with (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab) & where_ (#col1 .> param @1))+in printSQL qry :} SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4)) @@ -174,13 +135,13 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int64 Int32)- query =+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint8, "col2" ::: 'NotNull 'PGint4]+ qry = select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2) ( from (table (#tab `as` #table1)) & groupBy #col1 & having (sum_ (Distinct #col2) .> 1) )-in printSQL query+in printSQL qry :} SELECT COALESCE(sum(ALL "col2"), (0 :: int8)) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > (1 :: int8)) @@ -188,9 +149,9 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab) & orderBy [#col1 & Asc])-in printSQL query+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab) & orderBy [#col1 & Asc])+in printSQL qry :} SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC @@ -207,8 +168,8 @@ >>> :{ type OrdersConstraints = '["pk_orders" ::: PrimaryKey '["id"]- ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]- ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]+ ,"fk_customers" ::: ForeignKey '["customer_id"] "public" "customers" '["id"]+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "public" "shippers" '["id"] ] :} >>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]@@ -222,19 +183,17 @@ :} >>> :{-data Order = Order- { price :: Float- , customerName :: Text- , shipperName :: Text- } deriving GHC.Generic-instance SOP.Generic Order-instance SOP.HasDatatypeInfo Order+type OrderRow =+ '[ "price" ::: 'NotNull 'PGfloat4+ , "customerName" ::: 'NotNull 'PGtext+ , "shipperName" ::: 'NotNull 'PGtext+ ] :} >>> :{ let- query :: Query_ (Public OrdersSchema) () Order- query = select_+ qry :: Query lat with (Public OrdersSchema) params OrderRow+ qry = select_ ( #o ! #price `as` #price :* #c ! #name `as` #customerName :* #s ! #name `as` #shipperName )@@ -243,35 +202,19 @@ (#o ! #customer_id .== #c ! #id) & innerJoin (table (#shippers `as` #s)) (#o ! #shipper_id .== #s ! #id)) )-in printSQL query+in printSQL qry :} SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id") ->>> :{-let- query :: Query_ (Public OrdersSchema) () Order- query = select_- ( #o ! #price `as` #price :*- #c ! #name `as` #customerName :*- #s ! #name `as` #shipperName )- ( from (table (#orders `as` #o)- & (inner.JoinLateral) (select Star (from (table #customers)) `as` #c)- (#o ! #customer_id .== #c ! #id)- & (inner.JoinLateral) (select Star (from (table #shippers)) `as` #s)- (#o ! #shipper_id .== #s ! #id)) )-in printSQL query-:}-SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN LATERAL (SELECT * FROM "customers" AS "customers") AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN LATERAL (SELECT * FROM "shippers" AS "shippers") AS "s" ON ("o"."shipper_id" = "s"."id")- self-join: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))-in printSQL query+in printSQL qry :} SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2" @@ -279,11 +222,11 @@ >>> :{ let- query :: Query_ db () (Row String Bool)- query = values+ qry :: Query lat with db params '["col1" ::: 'NotNull 'PGtext, "col2" ::: 'NotNull 'PGbool]+ qry = values ("true" `as` #col1 :* true `as` #col2) ["false" `as` #col1 :* false `as` #col2]-in printSQL query+in printSQL qry :} SELECT * FROM (VALUES ((E'true' :: text), TRUE), ((E'false' :: text), FALSE)) AS t ("col1", "col2") @@ -291,51 +234,114 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))-in printSQL query+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))+in printSQL qry :} (SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab") -with queries:+with query: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = with (+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = with ( select Star (from (table #tab)) `as` #cte1 :>> select Star (from (common #cte1)) `as` #cte2 ) (select Star (from (common #cte2)))-in printSQL query+in printSQL qry :} WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" -window function queries+window functions: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int64)- query = select+ qry :: Query '[] with (Public Schema) db '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint8]+ qry = select (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc]))) (from (table #tab))-in printSQL query+in printSQL qry :} SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab" -correlated subqueries+correlated subqueries: >>> :{ let- query :: Query_ (Public Schema) () (Only Int32)- query =- select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4]+ qry =+ select #col1 (from (table (#tab `as` #t1)) & where_ (exists ( select Star (from (table (#tab `as` #t2)) & where_ (#t2 ! #col2 .== #t1 ! #col1)))))-in printSQL query+in printSQL qry :}-SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))+SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))+-}+newtype Query+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (row :: RowType)+ = UnsafeQuery { renderQuery :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (Query lat with db params row) where renderSQL = renderQuery +{- |+The `Query_` type is parameterized by a @db@ `SchemasType`,+against which the query is type-checked, an input @params@ Haskell `Type`,+and an ouput row Haskell `Type`.++A `Query_` can be run+using `Squeal.PostgreSQL.Session.runQueryParams`, or if @params = ()@+using `Squeal.PostgreSQL.Session.runQuery`.++Generally, @params@ will be a Haskell tuple or record whose entries+may be referenced using positional+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a+Haskell record, whose entries will be targeted using overloaded labels.++`Query_` is a type family which resolves into a `Query`,+so don't be fooled by the input params and output row Haskell `Type`s,+which are converted into appropriate+Postgres @[@`NullType`@]@ params and `RowType` rows.+Use `Squeal.PostgreSQL.Session.Statement.query` to+fix actual Haskell input params and output rows.++>>> :set -XDeriveAnyClass -XDerivingStrategies+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+data Row = Row { col1 :: Maybe Int64, col2 :: String }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :{+let+ qry :: Query_ (Public Schema) (Int64, Bool) Row+ qry = select Star (from (table #tab) & where_ (#col1 .> param @1 .&& notNull (param @2)))+ stmt :: Statement (Public Schema) (Int64, Bool) Row+ stmt = query qry+:}++>>> :type qry+qry+ :: Query+ '[]+ '[]+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ '[ 'NotNull 'PGint8, 'NotNull 'PGbool]+ '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext]+>>> :type stmt+stmt+ :: Statement+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ (Int64, Bool)+ Row -} type family Query_ (db :: SchemasType)
src/Squeal/PostgreSQL/Query/From.hs view
@@ -82,7 +82,11 @@ table (tab `As` alias) = UnsafeFromClause $ renderSQL tab <+> "AS" <+> renderSQL alias --- | `subquery` derives a table from a `Query`.+{- | `subquery` derives a table from a `Query`.+The subquery may not reference columns provided by preceding `FromClause` items.+Use `Squeal.PostgreSQL.Query.From.Join.JoinLateral`+if the subquery must reference columns provided by preceding `FromClause` items.+-} subquery :: Aliased (Query lat with db params) query -- ^ aliased `Query`
src/Squeal/PostgreSQL/Query/From/Join.hs view
@@ -81,8 +81,6 @@ -- ^ Subqueries can be preceded by `JoinLateral`. -- This allows them to reference columns provided -- by preceding `FromClause` items.- -- `subquery` is evaluated independently and so- -- cannot cross-reference any other `FromClause` item. -> JoinItem lat with db params left '[query] JoinFunction :: SetFun db arg set@@ -96,7 +94,7 @@ :: SListI args => SetFunN db args set -- ^ Set returning multi-argument functions- -- can be preceded by `JoinFunction`.+ -- can be preceded by `JoinFunctionN`. -- This allows them to reference columns provided -- by preceding `FromClause` items. -> NP (Expression 'Ungrouped lat with db params left) args
src/Squeal/PostgreSQL/Query/Select.hs view
@@ -103,24 +103,24 @@ (Expression grp lat with db params from ty) (Selection grp lat with db params from row) where expr `as` col = List (expr `as` col)-instance (Has tab (Join lat from) row0, Has col row0 ty, row1 ~ '[col ::: ty])+instance (Has tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty]) => IsQualified tab col (Selection 'Ungrouped lat with db params from row1) where tab ! col = tab ! col `as` col instance- ( Has tab (Join lat from) row0+ ( Has tab (Join from lat) row0 , Has col row0 ty , row1 ~ '[col ::: ty] , GroupedBy tab col bys ) => IsQualified tab col (Selection ('Grouped bys) lat with db params from row1) where tab ! col = tab ! col `as` col-instance (HasUnique tab (Join lat from) row0, Has col row0 ty, row1 ~ '[col ::: ty])+instance (HasUnique tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty]) => IsLabel col (Selection 'Ungrouped lat with db params from row1) where fromLabel = fromLabel @col `as` Alias instance- ( HasUnique tab (Join lat from) row0+ ( HasUnique tab (Join from lat) row0 , Has col row0 ty , row1 ~ '[col ::: ty] , GroupedBy tab col bys )
src/Squeal/PostgreSQL/Query/Table.hs view
@@ -40,10 +40,15 @@ , having , limit , offset+ , lockRows -- * Grouping , By (..) , GroupByClause (..) , HavingClause (..)+ -- * Row Locks+ , LockingClause (..)+ , LockStrength (..)+ , Waiting (..) ) where import Control.DeepSeq@@ -72,7 +77,7 @@ -- | A `TableExpression` computes a table. The table expression contains -- a `fromClause` that is optionally followed by a `whereClause`, -- `groupByClause`, `havingClause`, `orderByClause`, `limitClause`--- and `offsetClause`s. Trivial table expressions simply refer+-- `offsetClause` and `lockingClauses`. Trivial table expressions simply refer -- to a table on disk, a so-called base table, but more complex expressions -- can be used to modify or combine base tables in various ways. data TableExpression@@ -122,19 +127,22 @@ -- if nonempty. The offset count says to skip that many rows before -- beginning to return rows. The rows are skipped before the limit count -- is applied.+ , lockingClauses :: [LockingClause from]+ -- ^ `lockingClauses` can be added to a table expression with `lockRows`. } deriving (GHC.Generic) -- | Render a `TableExpression` instance RenderSQL (TableExpression grp lat with db params from) where renderSQL- (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat+ (TableExpression frm' whs' grps' hvs' srts' lims' offs' lks') = mconcat [ "FROM ", renderSQL frm' , renderWheres whs' , renderSQL grps' , renderSQL hvs' , renderSQL srts' , renderLimits lims'- , renderOffsets offs' ]+ , renderOffsets offs'+ , renderLocks lks' ] where renderWheres = \case [] -> ""@@ -145,6 +153,7 @@ renderOffsets = \case [] -> "" offs -> " OFFSET" <+> fromString (show (sum offs))+ renderLocks = foldr (\l b -> b <+> renderSQL l) "" -- | A `from` generates a `TableExpression` from a table reference that can be -- a table name, or a derived table such as a subquery, a JOIN construct,@@ -155,7 +164,7 @@ from :: FromClause lat with db params from -- ^ table reference -> TableExpression 'Ungrouped lat with db params from-from tab = TableExpression tab [] noGroups NoHaving [] [] []+from tab = TableExpression tab [] noGroups NoHaving [] [] [] [] -- | A `where_` is an endomorphism of `TableExpression`s which adds a -- search condition to the `whereClause`.@@ -181,6 +190,7 @@ , orderByClause = [] , limitClause = limitClause rels , offsetClause = offsetClause rels+ , lockingClauses = lockingClauses rels } -- | A `having` is an endomorphism of `TableExpression`s which adds a@@ -211,6 +221,22 @@ -> TableExpression grp lat with db params from offset off rels = rels {offsetClause = off : offsetClause rels} +{- | Add a `LockingClause` to a `TableExpression`.+Multiple `LockingClause`s can be written if it is necessary+to specify different locking behavior for different tables.+If the same table is mentioned (or implicitly affected)+by more than one locking clause, then it is processed+as if it was only specified by the strongest one.+Similarly, a table is processed as `NoWait` if that is specified+in any of the clauses affecting it. Otherwise, it is processed+as `SkipLocked` if that is specified in any of the clauses affecting it.+-}+lockRows+ :: LockingClause from -- ^ row-level lock+ -> TableExpression grp lat with db params from+ -> TableExpression grp lat with db params from+lockRows lck tab = tab {lockingClauses = lck : lockingClauses tab}+ {----------------------------------------- Grouping -----------------------------------------}@@ -287,3 +313,96 @@ Having [] -> "" Having conditions -> " HAVING" <+> commaSeparated (renderSQL <$> conditions)++{- |+If specific tables are named in a locking clause,+then only rows coming from those tables are locked;+any other tables used in the `Squeal.PostgreSQL.Query.Select.select` are simply read as usual.+A locking clause with a `Nil` table list affects all tables used in the statement.+If a locking clause is applied to a `view` or `subquery`,+it affects all tables used in the `view` or `subquery`.+However, these clauses do not apply to `Squeal.PostgreSQL.Query.With.with` queries referenced by the primary query.+If you want row locking to occur within a `Squeal.PostgreSQL.Query.With.with` query,+specify a `LockingClause` within the `Squeal.PostgreSQL.Query.With.with` query.+-}+data LockingClause from where+ For+ :: HasAll tabs from tables+ => LockStrength -- ^ lock strength+ -> NP Alias tabs -- ^ table list+ -> Waiting -- ^ wait or not+ -> LockingClause from+instance RenderSQL (LockingClause from) where+ renderSQL (For str tabs wt) =+ "FOR" <+> renderSQL str+ <> case tabs of+ Nil -> ""+ _ -> " OF" <+> renderSQL tabs+ <> renderSQL wt++{- |+Row-level locks, which are listed as below with the contexts+in which they are used automatically by PostgreSQL.+Note that a transaction can hold conflicting locks on the same row,+even in different subtransactions; but other than that,+two transactions can never hold conflicting locks on the same row.+Row-level locks do not affect data querying;+they block only writers and lockers to the same row.+Row-level locks are released at transaction end or during savepoint rollback.+-}+data LockStrength+ = Update+ {- ^ `For` `Update` causes the rows retrieved by the `Squeal.PostgreSQL.Query.Select.select` statement+ to be locked as though for update. This prevents them from being locked,+ modified or deleted by other transactions until the current transaction ends.+ That is, other transactions that attempt `Squeal.PostgreSQL.Manipulation.Update.update`, `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`,+ `Squeal.PostgreSQL.Query.Select.select` `For` `Update`, `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`,+ `Squeal.PostgreSQL.Query.Select.select` `For` `Share` or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` of these rows will be blocked+ until the current transaction ends; conversely, `Squeal.PostgreSQL.Query.Select.select` `For` `Update` will wait+ for a concurrent transaction that has run any of those commands on the same row,+ and will then lock and return the updated row (or no row, if the row was deleted).+ Within a `Squeal.PostgreSQL.Session.Transaction.RepeatableRead` or `Squeal.PostgreSQL.Session.Transaction.Serializable` transaction, however, an error will be+ thrown if a row to be locked has changed since the transaction started.++ The `For` `Update` lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` a row,+ and also by an `Update` that modifies the values on certain columns.+ Currently, the set of columns considered for the `Squeal.PostgreSQL.Manipulation.Update.update` case are those+ that have a unique index on them that can be used in a foreign key+ (so partial indexes and expressional indexes are not considered),+ but this may change in the future.-}+ | NoKeyUpdate+ {- | Behaves similarly to `For` `Update`, except that the lock acquired is weaker:+ this lock will not block `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` commands that attempt to acquire+ a lock on the same rows. This lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Update.update`+ that does not acquire a `For` `Update` lock.-}+ | Share+ {- | Behaves similarly to `For` `Share`, except that the lock is weaker:+ `Squeal.PostgreSQL.Query.Select.select` `For` `Update` is blocked, but not `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`.+ A key-shared lock blocks other transactions from performing+ `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` or any `Squeal.PostgreSQL.Manipulation.Update.update` that changes the key values,+ but not other `Update`, and neither does it prevent `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`,+ `Squeal.PostgreSQL.Query.Select.select` `For` `Share`, or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare`.-}+ | KeyShare+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance RenderSQL LockStrength where+ renderSQL = \case+ Update -> "UPDATE"+ NoKeyUpdate -> "NO KEY UPDATE"+ Share -> "SHARE"+ KeyShare -> "KEY SHARE"++-- | To prevent the operation from `Waiting` for other transactions to commit,+-- use either the `NoWait` or `SkipLocked` option.+data Waiting+ = Wait+ -- ^ wait for other transactions to commit+ | NoWait+ -- ^ reports an error, rather than waiting+ | SkipLocked+ -- ^ any selected rows that cannot be immediately locked are skipped+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance RenderSQL Waiting where+ renderSQL = \case+ Wait -> ""+ NoWait -> " NOWAIT"+ SkipLocked -> " SKIP LOCKED"
src/Squeal/PostgreSQL/Query/With.hs view
@@ -50,9 +50,42 @@ -- $setup -- >>> import Squeal.PostgreSQL --- | `with` provides a way to write auxiliary statements for use in a larger query.--- These statements, referred to as `CommonTableExpression`s, can be thought of as--- defining temporary tables that exist just for one query.+{- | `with` provides a way to write auxiliary statements for use in a larger query.+These statements, referred to as `CommonTableExpression`s, can be thought of as+defining temporary tables that exist just for one query.++`with` can be used for a `Query`. Multiple `CommonTableExpression`s can be+chained together with the `Path` constructor `:>>`, and each `CommonTableExpression`+is constructed via overloaded `as`.++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = with (+ select Star (from (table #tab)) `as` #cte1 :>>+ select Star (from (common #cte1)) `as` #cte2+ ) (select Star (from (common #cte2)))+in printSQL qry+:}+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++You can use data-modifying statements in `with`. This allows you to perform several+different operations in the same query. An example is:++>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]+>>> :{+let+ manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]+ manp = with+ (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)+ (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))+in printSQL manp+:}+WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del"+-} class With statement where with :: Path (CommonTableExpression statement db params) with0 with1@@ -65,21 +98,30 @@ with ctes query = UnsafeQuery $ "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL query -{- |+{- | A `withRecursive` `Query` can refer to its own output.+A very simple example is this query to sum the integers from 1 through 100:+ >>> import Data.Monoid (Sum (..)) >>> import Data.Int (Int64) >>> :{ let- query :: Query_ schema () (Sum Int64)- query = withRecursive- ( values_ ((1 & astype int) `as` #n)- `unionAll`- select_ ((#n + 1) `as` #n)- (from (common #t) & where_ (#n .< 100)) `as` #t )- ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))- in printSQL query+ sum100 :: Statement db () (Sum Int64)+ sum100 = query $+ withRecursive+ ( values_ ((1 & astype int) `as` #n)+ `unionAll`+ select_ ((#n + 1) `as` #n)+ (from (common #t) & where_ (#n .< 100)) `as` #t )+ ( select_+ (fromNull 0 (sum_ (All #n)) `as` #getSum)+ (from (common #t) & groupBy Nil) )+ in printSQL sum100 :} WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (((1 :: int4) :: int))) AS t ("n")) UNION ALL (SELECT ("n" + (1 :: int4)) AS "n" FROM "t" AS "t" WHERE ("n" < (100 :: int4)))) SELECT COALESCE(sum(ALL "n"), (0 :: int8)) AS "getSum" FROM "t" AS "t"++The general form of a recursive WITH query is always a non-recursive term,+then `union` (or `unionAll`), then a recursive term, where+only the recursive term can contain a reference to the query's own output. -} withRecursive :: Aliased (Query lat (recursive ': with) db params) recursive
src/Squeal/PostgreSQL/Session.hs view
@@ -6,8 +6,8 @@ Stability: experimental Using Squeal in your application will come down to defining-the @db@ of your database and including @PQ db db@ in your-application's monad transformer stack, giving it an instance of `MonadPQ`.+the @DB :: @`SchemasType` of your database and including @PQ DB DB@ in your+application's monad transformer stack, giving it an instance of `MonadPQ` @DB@. -} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}@@ -38,9 +38,12 @@ ) where import Control.Category+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..), MonadMask(..)) import Control.Monad.Except import Control.Monad.Morph import Control.Monad.Reader+import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) import UnliftIO (MonadUnliftIO (..), bracket, throwIO) import Data.ByteString (ByteString) import Data.Foldable@@ -260,6 +263,53 @@ withRunInIO inner = PQ $ \conn -> withRunInIO $ \(run :: (forall x . m x -> IO x)) -> K <$> inner (\pq -> run $ unK <$> unPQ pq conn)++instance (MonadBase b m)+ => MonadBase b (PQ schema schema m) where+ liftBase = lift . liftBase++instance db0 ~ db1 => MonadTransControl (PQ db0 db1) where+ type StT (PQ db0 db1) a = a+ liftWith f = PQ $ \conn -> K <$> (f $ \pq -> unK <$> unPQ pq conn)+ restoreT ma = PQ . const $ K <$> ma++-- | A snapshot of the state of a `PQ` computation, used in MonadBaseControl Instance+type PQRun schema =+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)++instance (MonadBaseControl b m, schema0 ~ schema1)+ => MonadBaseControl b (PQ schema0 schema1 m) where+ type StM (PQ schema0 schema1 m) x = StM m (K x schema0)+ restoreM = PQ . const . restoreM+ liftBaseWith f =+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run+ where+ pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a+ pqliftWith g = PQ $ \ conn ->+ fmap K (g $ \ pq -> unPQ pq conn)++instance (MonadThrow m, db0 ~ db1)+ => MonadThrow (PQ db0 db1 m) where+ throwM = lift . throwM++instance (MonadCatch m, db0 ~ db1)+ => MonadCatch (PQ db0 db1 m) where+ catch (PQ m) f = PQ $ \k -> m k `catch` \e -> unPQ (f e) k++instance (MonadMask m, db0 ~ db1)+ => MonadMask (PQ db0 db1 m) where+ mask a = PQ $ \e -> mask $ \u -> unPQ (a $ q u) e+ where q u (PQ b) = PQ (u . b)++ uninterruptibleMask a =+ PQ $ \k -> uninterruptibleMask $ \u -> unPQ (a $ q u) k+ where q u (PQ b) = PQ (u . b)++ generalBracket acquire release use = PQ $ \k ->+ K <$> generalBracket+ (unK <$> unPQ acquire k)+ (\resource exitCase -> unK <$> unPQ (release resource exitCase) k)+ (\resource -> unK <$> unPQ (use resource) k) instance (Monad m, Semigroup r, db0 ~ db1) => Semigroup (PQ db0 db1 m r) where f <> g = pqAp (fmap (<>) f) g
src/Squeal/PostgreSQL/Session/Connection.hs view
@@ -55,7 +55,7 @@ >>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]] >>> :set -XTypeApplications >>> :set -XOverloadedStrings->>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Note that, for now, squeal doesn't offer any protection from connecting with the wrong schema!
src/Squeal/PostgreSQL/Session/Decode.hs view
@@ -32,11 +32,14 @@ FromPG (..) , devalue , rowValue+ , enumValue -- * Decode Rows , DecodeRow (..) , decodeRow , runDecodeRow , genericRow+ , appendRows+ , consRow -- * Decoding Classes , FromValue (..) , FromField (..)@@ -57,6 +60,8 @@ import Data.Int (Int16, Int32, Int64) import Data.Kind import Data.Scientific (Scientific)+import Data.String (fromString)+import Data.Text (Text) import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime) import Data.UUID.Types (UUID) import Data.Vector (Vector)@@ -153,14 +158,14 @@ , imaginary :: Double } deriving stock GHC.Generic deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)- deriving (IsPG, FromPG) via (Composite Complex)+ deriving (IsPG, FromPG) via Composite Complex :} >>> :{ data Direction = North | South | East | West deriving stock GHC.Generic deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)- deriving (IsPG, FromPG) via (Enumerated Direction)+ deriving (IsPG, FromPG) via Enumerated Direction :} -}@@ -199,6 +204,30 @@ fromPG = devalue bytea_strict instance FromPG Lazy.ByteString where fromPG = devalue bytea_lazy+instance KnownNat n => FromPG (VarChar n) where+ fromPG = devalue $ text_strict >>= \t ->+ case varChar t of+ Nothing -> throwError $ Strict.Text.pack $ concat+ [ "Source for VarChar has wrong length"+ , "; expected length "+ , show (natVal (SOP.Proxy @n))+ , ", actual length "+ , show (Strict.Text.length t)+ , "."+ ]+ Just x -> pure x+instance KnownNat n => FromPG (FixChar n) where+ fromPG = devalue $ text_strict >>= \t ->+ case fixChar t of+ Nothing -> throwError $ Strict.Text.pack $ concat+ [ "Source for FixChar has wrong length"+ , "; expected length "+ , show (natVal (SOP.Proxy @n))+ , ", actual length "+ , show (Strict.Text.length t)+ , "."+ ]+ Just x -> pure x instance FromPG Day where fromPG = devalue date instance FromPG TimeOfDay where@@ -385,6 +414,8 @@ , Monad , MonadPlus , MonadError Strict.Text )+instance MonadFail (DecodeRow row) where+ fail = throwError . fromString -- | Run a `DecodeRow`. runDecodeRow@@ -393,6 +424,67 @@ -> Either Strict.Text y runDecodeRow = fmap runExcept . runReaderT . unDecodeRow +{- | Append two row decoders with a combining function.++>>> import GHC.Generics as GHC+>>> :{+data L = L {fst :: Int16, snd :: Char}+ deriving stock (GHC.Generic, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+data R = R {thrd :: Bool, frth :: Bool}+ deriving stock (GHC.Generic, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+type Row = '[+ "fst" ::: 'NotNull 'PGint2,+ "snd" ::: 'NotNull ('PGchar 1),+ "thrd" ::: 'NotNull 'PGbool,+ "frth" ::: 'NotNull 'PGbool]+:}++>>> :{+let+ decode :: DecodeRow Row (L,R)+ decode = appendRows (,) genericRow genericRow+ row4 =+ SOP.K (Just "\NUL\SOH") :*+ SOP.K (Just "a") :*+ SOP.K (Just "\NUL") :*+ SOP.K (Just "\NUL") :* Nil+in runDecodeRow decode row4+:}+Right (L {fst = 1, snd = 'a'},R {thrd = False, frth = False})+-}+appendRows+ :: SOP.SListI left+ => (l -> r -> z) -- ^ combining function+ -> DecodeRow left l -- ^ left decoder+ -> DecodeRow right r -- ^ right decoder+ -> DecodeRow (Join left right) z+appendRows f decL decR = decodeRow $ \row -> case disjoin row of+ (rowL, rowR) -> f <$> runDecodeRow decL rowL <*> runDecodeRow decR rowR++{- | Cons a column and a row decoder with a combining function.++>>> :{+let+ decode :: DecodeRow+ '["fst" ::: 'NotNull 'PGtext, "snd" ::: 'NotNull 'PGint2, "thrd" ::: 'NotNull ('PGchar 1)]+ (String, (Int16, Char))+ decode = consRow (,) #fst (consRow (,) #snd #thrd)+in runDecodeRow decode (SOP.K (Just "hi") :* SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)+:}+Right ("hi",(1,'a'))+-}+consRow+ :: FromValue head h+ => (h -> t -> z) -- ^ combining function+ -> Alias col -- ^ alias of head+ -> DecodeRow tail t -- ^ tail decoder+ -> DecodeRow (col ::: head ': tail) z+consRow f _ dec = decodeRow $ \case+ (SOP.K h :: SOP.K (Maybe Strict.ByteString) (col ::: head)) :* t+ -> f <$> fromValue @head h <*> runDecodeRow dec t+ -- | Smart constructor for a `DecodeRow`. decodeRow :: (SOP.NP (SOP.K (Maybe Strict.ByteString)) row -> Either Strict.Text y)@@ -443,3 +535,33 @@ => SOP.K (Maybe Strict.ByteString) ty -> Except Strict.Text (SOP.P y) runField = liftEither . fromField @ty . SOP.unK++{- |+>>> :{+data Dir = North | East | South | West+instance IsPG Dir where+ type PG Dir = 'PGenum '["north", "south", "east", "west"]+instance FromPG Dir where+ fromPG = enumValue $+ label @"north" North :*+ label @"south" South :*+ label @"east" East :*+ label @"west" West+:}+-}+enumValue+ :: (SOP.All KnownSymbol labels, PG y ~ 'PGenum labels)+ => NP (SOP.K y) labels+ -> StateT Strict.ByteString (Except Strict.Text) y+enumValue = devalue . enum . labels+ where+ labels+ :: SOP.All KnownSymbol labels+ => NP (SOP.K y) labels+ -> Text -> Maybe y+ labels = \case+ Nil -> \_ -> Nothing+ ((y :: SOP.K y label) :* ys) -> \ str ->+ if str == fromString (symbolVal (SOP.Proxy @label))+ then Just (SOP.unK y)+ else labels ys str
src/Squeal/PostgreSQL/Session/Encode.hs view
@@ -85,7 +85,7 @@ -- into the binary format of a PostgreSQL `PGType`. class IsPG x => ToPG (db :: SchemasType) (x :: Type) where -- | >>> :set -XTypeApplications -XDataKinds- -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+ -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" -- >>> runReaderT (toPG @'[] False) conn -- "\NUL" --@@ -120,6 +120,8 @@ toPG = pure . text_strict . Strict.Text.pack instance ToPG db Strict.ByteString where toPG = pure . bytea_strict instance ToPG db Lazy.ByteString where toPG = pure . bytea_lazy+instance ToPG db (VarChar n) where toPG = pure . text_strict . getVarChar+instance ToPG db (FixChar n) where toPG = pure . text_strict . getFixChar instance ToPG db Day where toPG = pure . date instance ToPG db TimeOfDay where toPG = pure . time_int instance ToPG db (TimeOfDay, TimeZone) where toPG = pure . timetz_int@@ -309,7 +311,7 @@ `EncodeParams` describes an encoding of a Haskell `Type` into a list of parameter `NullType`s. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[]@@ -336,7 +338,7 @@ >>> import qualified GHC.Generics as GHC >>> import qualified Generics.SOP as SOP >>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic)->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two@@ -374,7 +376,7 @@ {- | Cons a parameter encoding. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[]@@ -398,7 +400,7 @@ {- | End a parameter encoding. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[]@@ -422,7 +424,7 @@ {- | Encode 1 parameter. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[] '[ 'NotNull 'PGint4] Int32@@ -441,7 +443,7 @@ {- | Append parameter encodings. ->>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" >>> :{ let encode :: EncodeParams '[]
src/Squeal/PostgreSQL/Session/Migration.hs view
@@ -26,7 +26,7 @@ >>> :{ type EmailsTable = '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4@@ -71,7 +71,7 @@ nullable text `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) , down = dropTable #emails } :}@@ -84,7 +84,7 @@ >>> import Control.Monad.IO.Class >>> :{-withConnection "host=localhost port=5432 dbname=exampledb" $+withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;") -- suppress notices & pqThen (liftIO (putStrLn "Migrate"))@@ -97,7 +97,7 @@ We can also create a simple executable using `mainMigrateIso`. ->>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb" migrations+>>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" migrations >>> withArgs [] main Invalid command: "". Use:@@ -211,9 +211,9 @@ -- | A `Migration` consists of a name and a migration definition. data Migration def db0 db1 = Migration- { name :: Text -- ^ The `name` of a `Migration`.- -- Each `name` in a `Migration` should be unique.- , migration :: def db0 db1 -- ^ The migration of a `Migration`.+ { migrationName :: Text -- ^ The name of a `Migration`.+ -- Each `migrationName` should be unique.+ , migrationDef :: def db0 db1 -- ^ The migration of a `Migration`. } deriving (GHC.Generic) instance QFunctor Migration where qmap f (Migration n i) = Migration n (f i)@@ -233,11 +233,11 @@ where upMigration step = do executed <- do- result <- executeParams selectMigration (name step)+ result <- executeParams selectMigration (migrationName step) ntuples (result :: Result UTCTime) unless (executed == 1) $ do- _ <- unsafePQ . runIndexed $ migration step- executeParams_ insertMigration (name step)+ _ <- unsafePQ . runIndexed $ migrationDef step+ executeParams_ insertMigration (migrationName step) -- | pure migrations instance Migratory Definition (Indexed PQ IO ()) where runMigrations = runMigrations . qmap (qmap ixDefine)@@ -249,11 +249,11 @@ where downMigration (OpQ step) = do executed <- do- result <- executeParams selectMigration (name step)+ result <- executeParams selectMigration (migrationName step) ntuples (result :: Result UTCTime) unless (executed == 0) $ do- _ <- unsafePQ . runIndexed . getOpQ $ migration step- executeParams_ deleteMigration (name step)+ _ <- unsafePQ . runIndexed . getOpQ $ migrationDef step+ executeParams_ deleteMigration (migrationName step) -- | pure rewinds instance Migratory (OpQ Definition) (OpQ (Indexed PQ IO ())) where runMigrations = runMigrations . qmap (qmap (qmap ixDefine))@@ -303,8 +303,8 @@ ] data MigrationRow =- MigrationRow { migrationName :: Text- , migrationTime :: UTCTime }+ MigrationRow { name :: Text+ , executed_at :: UTCTime } deriving (GHC.Generic, Show) instance SOP.Generic MigrationRow@@ -344,9 +344,7 @@ & where_ (#name .== param @1) selectMigrations :: Statement MigrationsSchemas () MigrationRow-selectMigrations = query $- select_ (#name `as` #migrationName :* #executed_at `as` #migrationTime)- (from (table #schema_migrations))+selectMigrations = query $ select Star (from (table #schema_migrations)) {- | `mainMigrate` creates a simple executable from a connection string and a `Path` of `Migration`s. -}@@ -376,7 +374,7 @@ migrateStatus :: PQ schema schema IO () migrateStatus = unsafePQ $ do runNames <- getRunMigrationNames- let names = qtoList name migrations+ let names = qtoList migrationName migrations unrunNames = names \\ runNames liftIO $ displayRunned runNames >> displayUnrunned unrunNames @@ -420,7 +418,7 @@ migrateStatus :: PQ schema schema IO () migrateStatus = unsafePQ $ do runNames <- getRunMigrationNames- let names = qtoList name migrations+ let names = qtoList migrationName migrations unrunNames = names \\ runNames liftIO $ displayRunned runNames >> displayUnrunned unrunNames @@ -437,7 +435,7 @@ getRunMigrationNames :: PQ db0 db0 IO [Text] getRunMigrationNames =- fmap migrationName <$>+ fmap name <$> (unsafePQ (define createMigrations & pqThen (execute selectMigrations)) >>= getRows)
src/Squeal/PostgreSQL/Session/Monad.hs view
@@ -52,6 +52,9 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict +-- $setup+-- >>> import Squeal.PostgreSQL+ {- | `MonadPQ` is an @mtl@ style constraint, similar to `Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to run `Statement`s.@@ -59,30 +62,108 @@ class Monad pq => MonadPQ db pq | pq -> db where {- |- `executeParams` runs a `Statement`.- It calls `LibPQ.execParams` and doesn't afraid of anything.+ `executeParams` runs a `Statement` which takes out-of-line+ `Squeal.PostgreSQL.Expression.Parameter.parameter`s.++ >>> import Data.Int (Int32, Int64)+ >>> import Data.Monoid (Sum(Sum))+ >>> :{+ let+ sumOf :: Statement db (Int32, Int32) (Sum Int32)+ sumOf = query $ values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- executeParams sumOf (2,2)+ firstRow result+ :}+ Just (Sum {getSum = 4}) -}- executeParams :: Statement db x y -> x -> pq (Result y)+ executeParams+ :: Statement db x y+ -- ^ query or manipulation+ -> x+ -- ^ parameters+ -> pq (Result y) default executeParams :: (MonadTrans t, MonadPQ db m, pq ~ t m)- => Statement db x y -> x -> pq (Result y)+ => Statement db x y+ -- ^ query or manipulation+ -> x+ -- ^ parameters+ -> pq (Result y) executeParams statement params = lift $ executeParams statement params {- | `executeParams_` runs a returning-free `Statement`.- It calls `LibPQ.execParams` and doesn't afraid of anything.++ >>> type Column = 'NoDef :=> 'NotNull 'PGint4+ >>> type Columns = '["col1" ::: Column, "col2" ::: Column]+ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+ >>> type DB = Public Schema+ >>> import Data.Int(Int32)+ >>> :{+ let+ insertion :: Statement DB (Int32, Int32) ()+ insertion = manipulation $ insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (executeParams_ insertion (2,2))+ & pqThen (define teardown)+ :} -}- executeParams_ :: Statement db x () -> x -> pq ()+ executeParams_+ :: Statement db x ()+ -- ^ query or manipulation+ -> x+ -- ^ parameters+ -> pq () executeParams_ statement params = void $ executeParams statement params - {- |- `execute` runs a parameter-free `Statement`.+ {- | `execute` runs a parameter-free `Statement`.++ >>> import Data.Int(Int32)+ >>> :{+ let+ two :: Expr ('NotNull 'PGint4)+ two = 2+ twoPlusTwo :: Statement db () (Only Int32)+ twoPlusTwo = query $ values_ $ (two + two) `as` #fromOnly+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- execute twoPlusTwo+ firstRow result+ :}+ Just (Only {fromOnly = 4}) -}- execute :: Statement db () y -> pq (Result y)+ execute+ :: Statement db () y+ -- ^ query or manipulation+ -> pq (Result y) execute statement = executeParams statement () - {- |- `execute_` runs a parameter-free, returning-free `Statement`.+ {- | `execute_` runs a parameter-free, returning-free `Statement`.++ >>> :{+ let+ silence :: Statement db () ()+ silence = manipulation $+ UnsafeManipulation "Set client_min_messages TO WARNING"+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ execute_ silence+ :} -} execute_ :: Statement db () () -> pq () execute_ = void . execute@@ -91,32 +172,124 @@ `executePrepared` runs a `Statement` on a `Traversable` container by first preparing the statement, then running the prepared statement on each element.++ >>> import Data.Int (Int32, Int64)+ >>> import Data.Monoid (Sum(Sum))+ >>> :{+ let+ sumOf :: Statement db (Int32, Int32) (Sum Int32)+ sumOf = query $ values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ results <- executePrepared sumOf [(2,2),(3,3),(4,4)]+ traverse firstRow results+ :}+ [Just (Sum {getSum = 4}),Just (Sum {getSum = 6}),Just (Sum {getSum = 8})] -} executePrepared :: Traversable list- => Statement db x y -> list x -> pq (list (Result y))+ => Statement db x y+ -- ^ query or manipulation+ -> list x+ -- ^ list of parameters+ -> pq (list (Result y)) default executePrepared :: (MonadTrans t, MonadPQ db m, pq ~ t m) => Traversable list- => Statement db x y -> list x -> pq (list (Result y))+ => Statement db x y+ -- ^ query or manipulation+ -> list x+ -- ^ list of parameters+ -> pq (list (Result y)) executePrepared statement x = lift $ executePrepared statement x {- | `executePrepared_` runs a returning-free `Statement` on a `Foldable` container by first preparing the statement, then running the prepared statement on each element.++ >>> type Column = 'NoDef :=> 'NotNull 'PGint4+ >>> type Columns = '["col1" ::: Column, "col2" ::: Column]+ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+ >>> type DB = Public Schema+ >>> import Data.Int(Int32)+ >>> :{+ let+ insertion :: Statement DB (Int32, Int32) ()+ insertion = manipulation $ insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (executePrepared_ insertion [(2,2),(3,3),(4,4)])+ & pqThen (define teardown)+ :} -} executePrepared_ :: Foldable list- => Statement db x () -> list x -> pq ()+ => Statement db x ()+ -- ^ query or manipulation+ -> list x+ -- ^ list of parameters+ -> pq () default executePrepared_ :: (MonadTrans t, MonadPQ db m, pq ~ t m) => Foldable list- => Statement db x () -> list x -> pq ()+ => Statement db x ()+ -- ^ query or manipulation+ -> list x+ -- ^ list of parameters+ -> pq () executePrepared_ statement x = lift $ executePrepared_ statement x {- | `manipulateParams` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32)+ insertAdd = insertInto #tab + ( Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ ) OnConflictDoRaise+ ( Returning_ ((#col1 + #col2) `as` #fromOnly) )+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ result <- manipulateParams insertAdd (2::Int32,2::Int32)+ Just (Only answer) <- firstRow result+ liftIO $ print (answer :: Int32)+ )+ & pqThen (define teardown)+:}+4 -} manipulateParams :: ( MonadPQ db pq@@ -132,6 +305,31 @@ {- | `manipulateParams_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, for a returning-free statement.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Manipulation_ DB (Int32, Int32) ()+ insertion = insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (manipulateParams_ insertion (2::Int32,2::Int32))+ & pqThen (define teardown)+:} -} manipulateParams_ :: ( MonadPQ db pq@@ -146,6 +344,39 @@ {- | `manipulate` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, for a parameter-free statement.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertTwoPlusTwo :: Manipulation_ DB () (Only Int32)+ insertTwoPlusTwo = insertInto #tab + (Values_ $ Set 2 `as` #col1 :* Set 2 `as` #col2)+ OnConflictDoRaise+ (Returning_ ((#col1 + #col2) `as` #fromOnly))+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ result <- manipulate insertTwoPlusTwo+ Just (Only answer) <- firstRow result+ liftIO $ print (answer :: Int32)+ )+ & pqThen (define teardown)+:}+4 -} manipulate :: (MonadPQ db pq, GenericRow row y ys)@@ -156,6 +387,14 @@ {- | `manipulate_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`, for a returning-free, parameter-free statement.++>>> :{+let+ silence :: Manipulation_ db () ()+ silence = UnsafeManipulation "Set client_min_messages TO WARNING"+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ manipulate_ silence+:} -} manipulate_ :: MonadPQ db pq@@ -165,6 +404,24 @@ {- | `runQueryParams` runs a `Squeal.PostgreSQL.Query.Query`.++>>> import Data.Int (Int32, Int64)+>>> import Control.Monad.IO.Class+>>> import Data.Monoid (Sum(Sum))+>>> :{+let+ sumOf :: Query_ db (Int32, Int32) (Sum Int32)+ sumOf = values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- runQueryParams sumOf (2::Int32,2::Int32)+ Just (Sum four) <- firstRow result+ liftIO $ print (four :: Int32)+:}+4 -} runQueryParams :: ( MonadPQ db pq@@ -179,6 +436,21 @@ {- | `runQuery` runs a `Squeal.PostgreSQL.Query.Query`, for a parameter-free statement.++>>> import Data.Int (Int32, Int64)+>>> import Control.Monad.IO.Class+>>> import Data.Monoid (Sum(Sum))+>>> :{+let+ twoPlusTwo :: Query_ db () (Sum Int32)+ twoPlusTwo = values_ $ (2 + 2) `as` #getSum+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- runQuery twoPlusTwo+ Just (Sum four) <- firstRow result+ liftIO $ print (four :: Int32)+:}+4 -} runQuery :: (MonadPQ db pq, SOP.IsRecord y ys, SOP.AllZip FromField row ys)@@ -191,6 +463,41 @@ `traversePrepared` runs a `Squeal.PostgreSQL.Manipulation.Manipulation` on a `Traversable` container by first preparing the statement, then running the prepared statement on each element.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32)+ insertAdd = insertInto #tab + ( Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ ) OnConflictDoRaise+ ( Returning_ ((#col1 + #col2) `as` #fromOnly) )+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ results <- traversePrepared insertAdd [(2::Int32,2::Int32),(3,3),(4,4)]+ answers <- traverse firstRow results+ liftIO $ print [answer :: Int32 | Just (Only answer) <- answers]+ )+ & pqThen (define teardown)+:}+[4,6,8] -} traversePrepared :: ( MonadPQ db pq@@ -207,6 +514,41 @@ {- | `forPrepared` is a flipped `traversePrepared`++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32)+ insertAdd = insertInto #tab + ( Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ ) OnConflictDoRaise+ ( Returning_ ((#col1 + #col2) `as` #fromOnly) )+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ results <- forPrepared [(2::Int32,2::Int32),(3,3),(4,4)] insertAdd+ answers <- traverse firstRow results+ liftIO $ print [answer :: Int32 | Just (Only answer) <- answers]+ )+ & pqThen (define teardown)+:}+[4,6,8] -} forPrepared :: ( MonadPQ db pq@@ -223,10 +565,35 @@ forPrepared = flip traversePrepared {- |-`traversePrepared` runs a returning-free+`traversePrepared_` runs a returning-free `Squeal.PostgreSQL.Manipulation.Manipulation` on a `Foldable` container by first preparing the statement, then running the prepared statement on each element.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Manipulation_ DB (Int32, Int32) ()+ insertion = insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (traversePrepared_ insertion [(2::Int32,2::Int32),(3,3),(4,4)])+ & pqThen (define teardown)+:} -} traversePrepared_ :: ( MonadPQ db pq@@ -241,6 +608,31 @@ {- | `forPrepared_` is a flipped `traversePrepared_`++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Manipulation_ DB (Int32, Int32) ()+ insertion = insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (forPrepared_ [(2::Int32,2::Int32),(3,3),(4,4)] insertion)+ & pqThen (define teardown)+:} -} forPrepared_ :: ( MonadPQ db pq
src/Squeal/PostgreSQL/Session/Oid.hs view
@@ -54,7 +54,7 @@ -- | The `LibPQ.Oid` of a `PGType` -- -- >>> :set -XTypeApplications--- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb"+-- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" -- >>> runReaderT (oidOf @'[] @'PGbool) conn -- Oid 16 --
src/Squeal/PostgreSQL/Session/Pool.hs view
@@ -17,11 +17,11 @@ >>> :{ do let- query :: Query_ (Public '[]) () (Only Char)- query = values_ (inline 'a' `as` #fromOnly)- pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10+ qry :: Query_ (Public '[]) () (Only Char)+ qry = values_ (inline 'a' `as` #fromOnly)+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 chr <- usingConnectionPool pool $ do- result <- runQuery query+ result <- runQuery qry Just (Only a) <- firstRow result return a destroyConnectionPool pool
src/Squeal/PostgreSQL/Session/Result.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE FlexibleContexts , GADTs+ , LambdaCase , OverloadedStrings , ScopedTypeVariables , TypeApplications@@ -22,28 +23,36 @@ , firstRow , getRows , nextRow+ , cmdStatus+ , cmdTuples , ntuples , nfields , resultStatus , okResult , resultErrorMessage , resultErrorCode+ , liftResult ) where import Control.Exception (throw)-import Control.Monad (when)+import Control.Monad (when, (<=<)) import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.Text (Text) import Data.Traversable (for)+import Text.Read (readMaybe)+import UnliftIO (throwIO) +import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import qualified Data.Text.Encoding as Text import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Generics.SOP as SOP import Squeal.PostgreSQL.Session.Decode import Squeal.PostgreSQL.Session.Exception -{- | `Result`s are generated by running+{- | `Result`s are generated by executing `Squeal.PostgreSQL.Session.Statement`s in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`. @@ -138,6 +147,40 @@ resultStatus :: MonadIO io => Result y -> io LibPQ.ExecStatus resultStatus = liftResult LibPQ.resultStatus +{- |+Returns the command status tag from the SQL command+that generated the `Result`.+Commonly this is just the name of the command,+but it might include additional data such as the number of rows processed.+-}+cmdStatus :: MonadIO io => Result y -> io Text+cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus)+ where+ getCmdStatus = \case+ Nothing -> throwIO $ ConnectionException "LibPQ.cmdStatus"+ Just bytes -> return $ Text.decodeUtf8 bytes++{- |+Returns the number of rows affected by the SQL command.+This function returns `Just` the number of+rows affected by the SQL statement that generated the `Result`.+This function can only be used following the execution of a+SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH,+or COPY statement,or an EXECUTE of a prepared query that+contains an INSERT, UPDATE, or DELETE statement.+If the command that generated the PGresult was anything else,+`cmdTuples` returns `Nothing`.+-}+cmdTuples :: MonadIO io => Result y -> io (Maybe LibPQ.Row)+cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples)+ where+ getCmdTuples = \case+ Nothing -> throwIO $ ConnectionException "LibPQ.cmdTuples"+ Just bytes -> return $+ if ByteString.null bytes+ then Nothing+ else fromInteger <$> readMaybe (Char8.unpack bytes)+ okResult_ :: MonadIO io => LibPQ.Result -> io () okResult_ result = liftIO $ do status <- LibPQ.resultStatus result@@ -154,10 +197,10 @@ Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage" Just msg -> throw . SQLException $ SQLState status stateCode msg --- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`+-- | Check if a `Result`'s status is either `LibPQ.CommandOk` -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`.-okResult :: MonadIO io => SOP.K LibPQ.Result row -> io ()-okResult = okResult_ . SOP.unK+okResult :: MonadIO io => Result y -> io ()+okResult = liftResult okResult_ -- | Returns the error message most recently generated by an operation -- on the connection.
src/Squeal/PostgreSQL/Session/Transaction.hs view
@@ -138,7 +138,7 @@ , deferrableMode :: DeferrableMode } deriving (Show, Eq) --- | `TransactionMode` with a `ReadCommited` `IsolationLevel`,+-- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`, -- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`. defaultMode :: TransactionMode defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
src/Squeal/PostgreSQL/Type.hs view
@@ -9,7 +9,6 @@ -} {-# LANGUAGE AllowAmbiguousTypes- , CPP , DeriveAnyClass , DeriveFoldable , DeriveFunctor@@ -61,6 +60,10 @@ {- | The `Money` newtype stores a monetary value in terms of the number of cents, i.e. @$2,000.20@ would be expressed as @Money { cents = 200020 }@.++>>> :kind! PG Money+PG Money :: PGType+= 'PGmoney -} newtype Money = Money { cents :: Int64 } deriving stock (Eq, Ord, Show, Read, GHC.Generic)@@ -69,6 +72,10 @@ {- | The `Json` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGjson`.++>>> :kind! PG (Json [String])+PG (Json [String]) :: PGType+= 'PGjson -} newtype Json hask = Json {getJson :: hask} deriving stock (Eq, Ord, Show, Read, GHC.Generic)@@ -77,6 +84,10 @@ {- | The `Jsonb` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGjsonb`.++>>> :kind! PG (Jsonb [String])+PG (Jsonb [String]) :: PGType+= 'PGjsonb -} newtype Jsonb hask = Jsonb {getJsonb :: hask} deriving stock (Eq, Ord, Show, Read, GHC.Generic)@@ -85,6 +96,20 @@ {- | The `Composite` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGcomposite`.++>>> :{+data Complex = Complex+ { real :: Double+ , imaginary :: Double+ } deriving stock GHC.Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :kind! PG (Composite Complex)+PG (Composite Complex) :: PGType+= 'PGcomposite+ '["real" ::: 'NotNull 'PGfloat8,+ "imaginary" ::: 'NotNull 'PGfloat8] -} newtype Composite record = Composite {getComposite :: record} deriving stock (Eq, Ord, Show, Read, GHC.Generic)@@ -93,6 +118,10 @@ {- | The `Enumerated` newtype is an indication that the Haskell type it's applied to should be stored as a `Squeal.PostgreSQL.Type.Schema.PGenum`.++>>> :kind! PG (Enumerated Ordering)+PG (Enumerated Ordering) :: PGType+= 'PGenum '["LT", "EQ", "GT"] -} newtype Enumerated enum = Enumerated {getEnumerated :: enum} deriving stock (Eq, Ord, Show, Read, GHC.Generic)@@ -130,7 +159,12 @@ instance SOP.Generic (Only x) instance SOP.HasDatatypeInfo (Only x) --- | Variable-length text type with limit+{- | Variable-length text type with limit++>>> :kind! PG (VarChar 4)+PG (VarChar 4) :: PGType+= 'PGvarchar 4+-} newtype VarChar (n :: Nat) = VarChar Strict.Text deriving (Eq,Ord,Read,Show) @@ -145,7 +179,12 @@ getVarChar :: VarChar n -> Strict.Text getVarChar (VarChar t) = t --- | Fixed-length, blank padded+{- | Fixed-length, blank padded++>>> :kind! PG (FixChar 4)+PG (FixChar 4) :: PGType+= 'PGchar 4+-} newtype FixChar (n :: Nat) = FixChar Strict.Text deriving (Eq,Ord,Read,Show)
src/Squeal/PostgreSQL/Type/Alias.hs view
@@ -44,6 +44,7 @@ , mapAliased , Has , HasUnique+ , HasErr , HasAll , HasIn -- * Qualified Aliases@@ -183,13 +184,20 @@ -- | @Has alias fields field@ is a constraint that proves that -- @fields@ has a field of @alias ::: field@, inferring @field@ -- from @alias@ and @fields@.+type Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)+ = HasErr fields alias fields field++{- | `HasErr` is like `Has` except it also retains the original+list of fields being searched, so that error messages are more+useful.+-} class KnownSymbol alias =>- Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)+ HasErr err (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind) | alias fields -> field where instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1)- => Has alias (alias ::: field0 ': fields) field1-instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)- => Has alias (field' ': fields) field+ => HasErr err alias (alias ::: field0 ': fields) field1+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr err alias fields field)+ => HasErr err alias (field' ': fields) field {-| @HasIn fields (alias ::: field)@ is a constraint that proves that @fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
src/Squeal/PostgreSQL/Type/List.hs view
@@ -91,11 +91,6 @@ type family Elem x xs where Elem x '[] = 'False Elem x (x ': _) = 'True- Elem x (_ ': x ': _) = 'True- Elem x (_ ': _ ': x ': _) = 'True- Elem x (_ ': _ ': _ ': x ': _) = 'True- Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True- Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True Elem x (_ ': xs) = Elem x xs -- | @In x xs@ is a constraint that proves that @x@ is in @xs@.@@ -110,9 +105,5 @@ = 4 -} type family Length (xs :: [k]) :: Nat where- Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs- Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs- Length (_ ': _ ': _ : xs) = 3 + Length xs- Length (_ ': _ : xs) = 2 + Length xs- Length (_ : xs) = 1 + Length xs Length '[] = 0+ Length (_ : xs) = 1 + Length xs
src/Squeal/PostgreSQL/Type/PG.hs view
@@ -5,12 +5,11 @@ Maintainer: eitan@morphism.tech Stability: experimental -`Squeal.PostgreSQL.Type.PG` provides type families for turning Haskell-`Type`s into corresponding Postgres types.+Provides type families for turning Haskell `Type`s+into corresponding Postgres types. -} {-# LANGUAGE AllowAmbiguousTypes- , CPP , DeriveAnyClass , DeriveFoldable , DeriveFunctor@@ -275,13 +274,8 @@ -- | Calculates constructors of a datatype. type family ConstructorsOf (datatype :: Type.DatatypeInfo) :: [Type.ConstructorInfo] where-#if MIN_VERSION_generics_sop(0,5,0) ConstructorsOf ('Type.ADT _module _datatype constructors _strictness) = constructors-#else- ConstructorsOf ('Type.ADT _module _datatype constructors) =- constructors-#endif ConstructorsOf ('Type.Newtype _module _datatype constructor) = '[constructor]
src/Squeal/PostgreSQL/Type/Schema.hs view
@@ -5,8 +5,8 @@ Maintainer: eitan@morphism.tech Stability: experimental -`Squeal.PostgreSQL.Type.Schema` provides a type-level DSL-for kinds of Postgres types, tables, schema, constraints, and more.+Provides a type-level DSL for kinds of Postgres types,+tables, schema, constraints, and more. It also defines useful type families to operate on these. -} @@ -71,13 +71,13 @@ , AlterIfExists , Rename , RenameIfExists+ , SetSchema , ConstraintInvolves , DropIfConstraintsInvolve -- * Type Classification , PGNum , PGIntegral , PGFloating- , PGTypeOf , PGJsonType , PGJsonKey , SamePGType@@ -149,7 +149,7 @@ | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types. | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word. | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.- | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.+ | PGoid -- ^ Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables. | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype). | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types @@ -210,7 +210,7 @@ = Check [Symbol] | Unique [Symbol] | PrimaryKey [Symbol]- | ForeignKey [Symbol] Symbol [Symbol]+ | ForeignKey [Symbol] Symbol Symbol [Symbol] {- | A `TableConstraints` is a row of `TableConstraint`s. @@ -243,7 +243,7 @@ -- :} type TableType = (TableConstraints,ColumnsType) -{- | A `RowType` is a row of `NullType`. They correspond to Haskell+{- | A `RowType` is a row of `NullType`s. They correspond to Haskell record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places. >>> :{@@ -258,8 +258,8 @@ type RowType = [(Symbol,NullType)] {- | `FromType` is a row of `RowType`s. It can be thought of as-a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s-and `Squeal.PostgreSQL.Query.TableExpression`s.+a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.From.FromClause`s+and `Squeal.PostgreSQL.Query.Table.TableExpression`s. -} type FromType = [(Symbol,RowType)] @@ -287,10 +287,6 @@ -- | Integral Postgres types. type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8] --- | `PGTypeOf` forgets about @NULL@ and any column constraints.-type family PGTypeOf (ty :: NullType) :: PGType where- PGTypeOf (null pg) = pg- -- | Equality constraint on the underlying `PGType` of two columns. class SamePGType (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where@@ -311,8 +307,7 @@ -- | `NullifyType` is an idempotent that nullifies a `NullType`. type family NullifyType (ty :: NullType) :: NullType where- NullifyType ('Null ty) = 'Null ty- NullifyType ('NotNull ty) = 'Null ty+ NullifyType (null ty) = 'Null ty -- | `NullifyRow` is an idempotent that nullifies a `RowType`. type family NullifyRow (columns :: RowType) :: RowType where@@ -322,15 +317,15 @@ -- | `NullifyFrom` is an idempotent that nullifies a `FromType` -- used to nullify the left or right hand side of an outer join--- in a `Squeal.PostgreSQL.Query.FromClause`.+-- in a `Squeal.PostgreSQL.Query.From.FromClause`. type family NullifyFrom (tables :: FromType) :: FromType where NullifyFrom (table ::: columns ': tables) = table ::: NullifyRow columns ': NullifyFrom tables NullifyFrom '[] = '[] -- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in--- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@--- `Squeal.PostgreSQL.Definition.addColumn`.+-- `Squeal.PostgreSQL.Definition.Table.createTable` statements and in @ALTER TABLE@+-- `Squeal.PostgreSQL.Definition.Table.addColumn`. type family Create alias x xs where Create alias x '[] = '[alias ::: x] Create alias x (alias ::: y ': xs) = TypeError@@ -439,12 +434,18 @@ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs +-- | Move an object from one schema to another+type family SetSchema sch0 sch1 schema0 schema1 obj srt ty db where+ SetSchema sch0 sch1 schema0 schema1 obj srt ty db = Alter sch1+ (Create obj (srt ty) schema1)+ (Alter sch0 (DropSchemum obj srt schema0) db)+ -- | Check if a `TableConstraint` involves a column type family ConstraintInvolves column constraint where ConstraintInvolves column ('Check columns) = column `Elem` columns ConstraintInvolves column ('Unique columns) = column `Elem` columns ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns- ConstraintInvolves column ('ForeignKey columns tab refcolumns)+ ConstraintInvolves column ('ForeignKey columns sch tab refcolumns) = column `Elem` columns -- | Drop all `TableConstraint`s that involve a column@@ -455,7 +456,7 @@ (DropIfConstraintsInvolve column constraints) (alias ::: constraint ': DropIfConstraintsInvolve column constraints) --- | A `SchemumType` is a user-defined type, either a `Table`,+-- | A `SchemumType` is a user-created type, like a `Table`, -- `View` or `Typedef`. data SchemumType = Table TableType@@ -463,10 +464,17 @@ | Typedef PGType | Index IndexType | Function FunctionType+ | Procedure [NullType] | UnsafeSchemum Symbol --- | Use `:=>` to pair the parameter types with the return--- type of a function.+{- | Use `:=>` to pair the parameter types with the return+type of a function.++>>> :{+type family Fn :: FunctionType where+ Fn = '[ 'NotNull 'PGint4] :=> 'Returns ('NotNull 'PGint4)+:}+-} type FunctionType = ([NullType], ReturnsType) {- |@@ -500,7 +508,7 @@ = Returns NullType -- ^ function | ReturnsTable RowType -- ^ set returning function -{- | The schema of a database consists of a list of aliased,+{- | A schema of a database consists of a list of aliased, user-defined `SchemumType`s. >>> :{@@ -513,7 +521,7 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4@@ -548,12 +556,14 @@ -- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas -- the overloaded label, `fromLabel` is used for column references, -- `label`s are used for enum terms. A `label` is called with--- type application like `label @"beef"`.+-- type application like `label` @"beef". class IsPGlabel (label :: Symbol) expr where label :: expr instance label ~ label1 => IsPGlabel label (PGlabel label1) where label = PGlabel instance labels ~ '[label] => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil+instance IsPGlabel label (y -> K y label) where label = K+instance IsPGlabel label (y -> NP (K y) '[label]) where label y = K y :* Nil -- | A `PGlabel` unit type with an `IsPGlabel` instance data PGlabel (label :: Symbol) = PGlabel instance KnownSymbol label => RenderSQL (PGlabel label) where
test/Property.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE DataKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , DerivingVia , FlexibleContexts , GADTs , LambdaCase@@ -8,6 +12,7 @@ , ScopedTypeVariables , TypeApplications , TypeOperators+ , UndecidableInstances #-} module Main (main) where@@ -22,12 +27,17 @@ import Hedgehog hiding (Range) import Main.Utf8 import Squeal.PostgreSQL hiding (check)+import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Main as Main import qualified Hedgehog.Range as Range main :: IO ()-main = withUtf8 $ Main.defaultMain [checkSequential roundtrips]+main = withUtf8 $ do+ withConnection connectionString $ define createSchwarma+ Main.defaultMain [checkSequential roundtrips]+ withConnection connectionString $ define dropSchwarma roundtrips :: Group roundtrips = Group "roundtrips"@@ -53,6 +63,8 @@ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime) , roundtrip tstzrange (genRange genUTCTime) , roundtripOn normalizeIntRange daterange (genRange genDay)+ , roundtrip (typedef #schwarma) genSchwarma+ , roundtrip (vararray (typedef #schwarma)) genSchwarmaArray ] where genInt16 = Gen.int16 Range.exponentialBounded@@ -105,24 +117,26 @@ -- genTimeZone = Gen.element $ map (read @TimeZone) -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST" -- , "CDT", "MST", "MDT", "PST", "PDT" ]+ genSchwarma = Gen.enumBounded @_ @Schwarma+ genSchwarmaArray = VarArray <$> Gen.list (Range.constant 1 10) genSchwarma roundtrip- :: forall db x- . ( ToPG db x, FromPG x, Inline x- , OidOf db (PG x), PGTyped db (PG x)+ :: forall x+ . ( ToPG DB x, FromPG x, Inline x+ , OidOf DB (PG x), PGTyped DB (PG x) , Show x, Eq x )- => TypeExpression db ('NotNull (PG x))+ => TypeExpression DB ('NotNull (PG x)) -> Gen x -> (PropertyName, Property) roundtrip = roundtripOn id roundtripOn- :: forall db x- . ( ToPG db x, FromPG x, Inline x- , OidOf db (PG x), PGTyped db (PG x)+ :: forall x+ . ( ToPG DB x, FromPG x, Inline x+ , OidOf DB (PG x), PGTyped DB (PG x) , Show x, Eq x ) => (x -> x)- -> TypeExpression db ('NotNull (PG x))+ -> TypeExpression DB ('NotNull (PG x)) -> Gen x -> (PropertyName, Property) roundtripOn norm ty gen = propertyWithName $ do@@ -156,7 +170,7 @@ x = encodeFloat (b^n - 1) (l - n - 1) connectionString :: ByteString-connectionString = "host=localhost port=5432 dbname=exampledb"+connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int normalizeIntRange = \case@@ -203,3 +217,16 @@ stripped = \case '\NUL' -> "" ch -> [ch]++data Schwarma = Chicken | Lamb | Beef+ deriving stock (Eq, Show, Bounded, Enum, GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving (IsPG, FromPG, ToPG db, Inline) via Enumerated Schwarma++type DB = '["public" ::: '["schwarma" ::: 'Typedef (PG Schwarma)]]++createSchwarma :: Definition '["public" ::: '[]] DB+createSchwarma = createTypeEnumFrom @Schwarma #schwarma++dropSchwarma :: Definition DB '["public" ::: '[]]+dropSchwarma = dropType #schwarma
test/Spec.hs view
@@ -59,6 +59,14 @@ insertUser = insertInto_ #users (Values_ (Default `as` #id :* Set (param @1) `as` #name)) +insertUsers :: Text -> [Text] -> Statement DB () ()+insertUsers name1 names = manipulation $ insertInto_ #users $ Values+ (Default `as` #id :* Set (inline name1) `as` #name)+ [Default `as` #id :* Set (inline namei) `as` #name | namei <- names]++deleteUser :: Text -> Statement DB () ()+deleteUser name1 = manipulation $ deleteFrom_ #users (#name .== inline name1)+ setup :: Definition (Public '[]) DB setup = createTable #users@@ -71,9 +79,11 @@ teardown :: Definition DB (Public '[]) teardown = dropType #person >>> dropTable #users +silent :: Statement db () ()+silent = manipulation $ UnsafeManipulation "Set client_min_messages TO WARNING"+ silence :: MonadPQ db pq => pq ()-silence = manipulate_ $- UnsafeManipulation "SET client_min_messages TO WARNING;"+silence = execute_ silent setupDB :: IO () setupDB = withConnection connectionString $@@ -84,7 +94,7 @@ silence & pqThen (define teardown) connectionString :: ByteString-connectionString = "host=localhost port=5432 dbname=exampledb"+connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" data Person = Person { name :: Maybe String, age :: Maybe Int32 } deriving (Eq, Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)@@ -115,7 +125,7 @@ it "should manage concurrent transactions" $ do pool <- createConnectionPool- "host=localhost port=5432 dbname=exampledb" 1 0.5 10+ "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10 let qry :: Query_ (Public '[]) () (Only Char) qry = values_ (inline 'a' `as` #fromOnly)@@ -210,3 +220,30 @@ out2_array `shouldBe` Just (Only people) unsafe_array `shouldBe` Just (Only (VarArray [Composite adam])) nothings `shouldBe` Just (Only (Person Nothing Nothing))++ describe "cmdStatus and cmdTuples" $ do++ let+ statusAndTuples stmnt = withConnection connectionString $ do+ result <- execute stmnt+ status <- cmdStatus result+ tuples <- cmdTuples result+ return (status, tuples)++ it "should tell you about the command and the number of rows effected" $ do++ (status1, tuples1) <- statusAndTuples (insertUsers "Jonah" ["Isaiah"])+ status1 `shouldBe` "INSERT 0 2"+ tuples1 `shouldBe` Just 2++ (status2, tuples2) <- statusAndTuples (deleteUser "Noah")+ status2 `shouldBe` "DELETE 0"+ tuples2 `shouldBe` Just 0++ (status3, tuples3) <- statusAndTuples (deleteUser "Jonah")+ status3 `shouldBe` "DELETE 1"+ tuples3 `shouldBe` Just 1++ (status4, tuples4) <- statusAndTuples silent+ status4 `shouldBe` "SET"+ tuples4 `shouldBe` Nothing