squeal-postgresql 0.4.0.0 → 0.5.0.0
raw patch · 35 files changed
+7166/−4956 lines, 35 filesdep +unliftiodep +unliftio-pooldep −lifted-basedep −monad-controldep −transformers-base
Dependencies added: unliftio, unliftio-pool
Dependencies removed: lifted-base, monad-control, transformers-base
Files
- exe/Example.hs +25/−31
- squeal-postgresql.cabal +24/−7
- src/Squeal/PostgreSQL.hs +91/−94
- src/Squeal/PostgreSQL/Alias.hs +249/−0
- src/Squeal/PostgreSQL/Binary.hs +210/−115
- src/Squeal/PostgreSQL/Definition.hs +351/−225
- src/Squeal/PostgreSQL/Expression.hs +397/−1757
- src/Squeal/PostgreSQL/Expression/Aggregate.hs +447/−0
- src/Squeal/PostgreSQL/Expression/Collection.hs +169/−0
- src/Squeal/PostgreSQL/Expression/Comparison.hs +206/−0
- src/Squeal/PostgreSQL/Expression/Json.hs +469/−0
- src/Squeal/PostgreSQL/Expression/Literal.hs +87/−0
- src/Squeal/PostgreSQL/Expression/Logic.hs +105/−0
- src/Squeal/PostgreSQL/Expression/Math.hs +102/−0
- src/Squeal/PostgreSQL/Expression/Null.hs +104/−0
- src/Squeal/PostgreSQL/Expression/Parameter.hs +80/−0
- src/Squeal/PostgreSQL/Expression/SetOf.hs +106/−0
- src/Squeal/PostgreSQL/Expression/Sort.hs +85/−0
- src/Squeal/PostgreSQL/Expression/Subquery.hs +120/−0
- src/Squeal/PostgreSQL/Expression/Text.hs +64/−0
- src/Squeal/PostgreSQL/Expression/TextSearch.hs +158/−0
- src/Squeal/PostgreSQL/Expression/Time.hs +197/−0
- src/Squeal/PostgreSQL/Expression/Type.hs +295/−0
- src/Squeal/PostgreSQL/Expression/Window.hs +284/−0
- src/Squeal/PostgreSQL/List.hs +141/−0
- src/Squeal/PostgreSQL/Manipulation.hs +383/−312
- src/Squeal/PostgreSQL/Migration.hs +330/−179
- src/Squeal/PostgreSQL/PG.hs +366/−0
- src/Squeal/PostgreSQL/PQ.hs +191/−171
- src/Squeal/PostgreSQL/Pool.hs +53/−52
- src/Squeal/PostgreSQL/Query.hs +1044/−1412
- src/Squeal/PostgreSQL/Render.hs +47/−14
- src/Squeal/PostgreSQL/Schema.hs +66/−497
- src/Squeal/PostgreSQL/Transaction.hs +97/−71
- test/Specs/ExceptionHandling.hs +23/−19
exe/Example.hs view
@@ -11,8 +11,7 @@ module Main (main, main2) where -import Control.Monad (void)-import Control.Monad.Base (liftBase, MonadBase)+import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32) import Data.Monoid ((<>)) import Data.Text (Text)@@ -41,8 +40,10 @@ ]) ] -setup :: Definition '[] Schema-setup = +type Schemas = Public Schema++setup :: Definition (Public '[]) Schemas+setup = createTable #users ( serial `as` #id :* (text & notNullable) `as` #name :*@@ -57,54 +58,47 @@ foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) -teardown :: Definition Schema '[]+teardown :: Definition Schemas (Public '[]) teardown = dropTable #emails >>> dropTable #users -insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]- '[ "fromOnly" ::: 'NotNull 'PGint4 ]-insertUser = insertRows #users- (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []- OnConflictDoNothing (Returning (#id `as` #fromOnly))+insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)+insertUser = insertInto #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 Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]-insertEmail = insertRows #emails- ( Default `as` #id :*- Set (param @1) `as` #user_id :*- Set (param @2) `as` #email ) []- OnConflictDoNothing (Returning Nil)+insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()+insertEmail = insertInto_ #emails+ (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) -getUsers :: Query Schema '[]- '[ "userName" ::: 'NotNull 'PGtext- , "userEmail" ::: 'Null 'PGtext- , "userVec" ::: 'NotNull ('PGvararray ('Null 'PGint2))]-getUsers = select+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)) (#u ! #id .== #e ! #user_id)) ) -data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) } deriving (Show, GHC.Generic) instance SOP.Generic User instance SOP.HasDatatypeInfo User users :: [User]-users = - [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]- , User "Bob" Nothing [Just 2, Nothing]- , User "Carole" (Just "carole@hotmail.com") [Just 3]+users =+ [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])+ , User "Bob" Nothing (VarArray [Just 2, Nothing])+ , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3]) ] -session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()+session :: (MonadIO pq, MonadPQ Schemas pq) => pq () session = do- liftBase $ Char8.putStrLn "manipulating"+ liftIO $ Char8.putStrLn "manipulating" idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users]) ids <- traverse (fmap fromOnly . getRow 0) idResults traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))- liftBase $ Char8.putStrLn "querying"+ liftIO $ Char8.putStrLn "querying" usersResult <- runQuery getUsers usersRows <- getRows usersResult- liftBase $ print (usersRows :: [User])+ liftIO $ print (usersRows :: [User]) main :: IO () main = do@@ -122,7 +116,7 @@ main2 :: IO () main2 =- void . withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb" $ define setup & pqThen session & pqThen (define teardown)
squeal-postgresql.cabal view
@@ -1,5 +1,5 @@ name: squeal-postgresql-version: 0.4.0.0+version: 0.5.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal@@ -22,12 +22,32 @@ hs-source-dirs: src exposed-modules: Squeal.PostgreSQL+ Squeal.PostgreSQL.Alias Squeal.PostgreSQL.Binary Squeal.PostgreSQL.Definition Squeal.PostgreSQL.Expression+ Squeal.PostgreSQL.Expression.Aggregate+ Squeal.PostgreSQL.Expression.Collection+ Squeal.PostgreSQL.Expression.Comparison+ Squeal.PostgreSQL.Expression.Json+ Squeal.PostgreSQL.Expression.Literal+ Squeal.PostgreSQL.Expression.Logic+ Squeal.PostgreSQL.Expression.Math+ Squeal.PostgreSQL.Expression.Null+ Squeal.PostgreSQL.Expression.Parameter+ Squeal.PostgreSQL.Expression.SetOf+ Squeal.PostgreSQL.Expression.Sort+ Squeal.PostgreSQL.Expression.Subquery+ Squeal.PostgreSQL.Expression.Text+ Squeal.PostgreSQL.Expression.TextSearch+ Squeal.PostgreSQL.Expression.Time+ Squeal.PostgreSQL.Expression.Type+ Squeal.PostgreSQL.Expression.Window+ Squeal.PostgreSQL.List Squeal.PostgreSQL.Manipulation Squeal.PostgreSQL.Migration Squeal.PostgreSQL.Pool+ Squeal.PostgreSQL.PG Squeal.PostgreSQL.PQ Squeal.PostgreSQL.Render Squeal.PostgreSQL.Query@@ -43,9 +63,7 @@ , bytestring-strict-builder >= 0.4.5 , deepseq >= 1.4.3.0 , generics-sop >= 0.3.2.0- , lifted-base >= 0.2.3.12 , mmorph >= 1.1.1- , monad-control >= 1.0.2.3 , mtl >= 2.2.2 , network-ip >= 0.3.0.2 , postgresql-binary >= 0.12.1@@ -56,7 +74,8 @@ , text >= 1.2.3.0 , time >= 1.8.0.2 , transformers >= 0.5.2.0- , transformers-base >= 0.4.4+ , unliftio >= 0.2.10+ , unliftio-pool >= 0.2.1.0 , uuid-types >= 1.0.3 , vector >= 0.12.0.1 @@ -74,7 +93,7 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test/Specs- ghc-options: -Wall -main-is Specs+ ghc-options: -Wall main-is: Specs.hs other-modules: ExceptionHandling build-depends:@@ -85,7 +104,6 @@ , squeal-postgresql , text >= 1.2.2.2 , transformers >= 0.5.2.0- , transformers-base >= 0.4.4 , vector >= 0.12.0.1 executable squeal-postgresql-example@@ -101,5 +119,4 @@ , squeal-postgresql , text >= 1.2.2.2 , transformers >= 0.5.2.0- , transformers-base >= 0.4.4 , vector >= 0.12.0.1
src/Squeal/PostgreSQL.hs view
@@ -1,7 +1,7 @@ {-| Module: Squeal.PostgreSQL-Description: Squeel export module-Copyright: (c) Eitan Chatav, 2017+Description: Squeal export module+Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental @@ -11,17 +11,15 @@ First, we need some language extensions because Squeal uses modern GHC features. ->>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels->>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators- +>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs+ We'll need some imports. ->>> import Control.Monad (void)->>> import Control.Monad.Base (liftBase)+>>> import Control.Monad.IO.Class (liftIO) >>> import Data.Int (Int32) >>> import Data.Text (Text) >>> import Squeal.PostgreSQL->>> import Squeal.PostgreSQL.Render We'll use generics to easily convert between Haskell and PostgreSQL values. @@ -32,26 +30,26 @@ we use @DataKinds@ and @TypeOperators@. >>> :{+type UsersColumns =+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]+type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]+type EmailsColumns =+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "email" ::: 'NoDef :=> 'Null 'PGtext ]+type EmailsConstraints =+ '[ "pk_emails" ::: 'PrimaryKey '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ] type Schema =- '[ "users" ::: 'Table (- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- ])- , "emails" ::: 'Table (- '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4- , "email" ::: 'NoDef :=> 'Null 'PGtext- ])- ]+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)+ , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]+type Schemas = Public Schema :} Notice the use of type operators. -`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`, a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@ operator. @@ -60,7 +58,7 @@ yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator Next, we'll write `Definition`s to set up and tear down the schema. In-Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` +Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable` has two type parameters, corresponding to the schema before being run and the schema after. We can compose definitions using `>>>`. Here and in the rest of our commands we make use of overloaded@@ -68,8 +66,8 @@ >>> :{ let- setup :: Definition '[] Schema- setup = + setup :: Definition (Public '[]) Schemas+ setup = createTable #users ( serial `as` #id :* (text & notNullable) `as` #name )@@ -89,14 +87,14 @@ CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); -Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.+Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@. In our `createTable` commands we included `TableConstraint`s to define primary and foreign keys, making them somewhat complex. Our @teardown@ `Definition` is simpler. >>> :{ let- teardown :: Definition Schema '[]+ teardown :: Definition Schemas (Public '[]) teardown = dropTable #emails >>> dropTable #users :} @@ -104,51 +102,49 @@ DROP TABLE "emails"; DROP TABLE "users"; -Next, we'll write `Manipulation`s to insert data into our two tables.-A `Manipulation` like `insertRow`, `update` or `deleteFrom`-has three type parameters, the schema it refers to, a list of parameters-it can take as input, and a list of columns it produces as output. When+We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and+`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.++>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)+>>> instance SOP.Generic User+>>> instance SOP.HasDatatypeInfo User++Next, we'll write `Manipulation_`s to insert @User@s into our two tables.+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`+has three type parameters, the schemas it refers to, input parameters+and an output row. When we insert into the users table, we will need a parameter for the @name@ field but not for the @id@ field. Since it's serial, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into-the emails table. Take a careful look at the type and definition of both-of our inserts.-->>> :{-let- insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]- insertUser = insertRow #users- (Default `as` #id :* Set (param @1) `as` #name)- OnConflictDoNothing (Returning (#id `as` #fromOnly))-:}+the emails table. We can do this in a single `Manipulation_` by using a+`with` statement. >>> :{ let- insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]- insertEmail = insertRow #emails- ( Default `as` #id :*- Set (param @1) `as` #user_id :*- Set (param @2) `as` #email )- OnConflictDoNothing (Returning Nil)+ insertUser :: Manipulation_ Schemas User ()+ insertUser = with (u `as` #u) e+ where+ u = insertInto #users+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))+ e = insertInto_ #emails $ Select+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)+ (from (common #u)) :} >>> printSQL insertUser-INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"->>> printSQL insertEmail-INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING+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" -Next we write a `Query` to retrieve users from the database. We're not+Next we write a `Query_` to retrieve users from the database. We're not interested in the ids here, just the usernames and email addresses. We-need to use an inner join to get the right result. A `Query` is like a-`Manipulation` with the same kind of type parameters.+need to use an `innerJoin` to get the right result. A `Query_` is like a+`Manipulation_` with the same kind of type parameters. >>> :{ let- getUsers :: Query Schema '[]- '[ "userName" ::: 'NotNull 'PGtext- , "userEmail" ::: 'Null 'PGtext ]- getUsers = select+ getUsers :: Query_ Schemas () User+ getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail) ( from (table (#users `as` #u) & innerJoin (table (#emails `as` #e))@@ -158,22 +154,12 @@ >>> printSQL getUsers SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id") -Now that we've defined the SQL side of things, we'll need a Haskell type-for users. We give the type `Generics.SOP.Generic` and-`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows-we receive when we run @getUsers@. Notice that the record fields of the-@User@ type match the column names of @getUsers@.- ->>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)->>> instance SOP.Generic User->>> instance SOP.HasDatatypeInfo User--Let's also create some users to add to the database.+Let's create some users to add to the database. >>> :{ let users :: [User]- users = + users = [ User "Alice" (Just "alice@gmail.com") , User "Bob" Nothing , User "Carole" (Just "carole@hotmail.com")@@ -190,38 +176,49 @@ >>> :{ let- session :: PQ Schema Schema IO ()+ session :: PQ Schemas Schemas IO () session = do- idResults <- traversePrepared insertUser (Only . userName <$> users)- ids <- traverse (fmap fromOnly . getRow 0) idResults- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))+ _ <- traversePrepared_ insertUser users usersResult <- runQuery getUsers usersRows <- getRows usersResult- liftBase $ print (usersRows :: [User])+ liftIO $ print (usersRows :: [User]) in- void . withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb" $ define setup & pqThen session & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] -}-module Squeal.PostgreSQL- ( module Squeal.PostgreSQL.Binary- , module Squeal.PostgreSQL.Definition- , module Squeal.PostgreSQL.Expression- , module Squeal.PostgreSQL.Manipulation- , module Squeal.PostgreSQL.PQ- , module Squeal.PostgreSQL.Query- , module Squeal.PostgreSQL.Schema- , module Squeal.PostgreSQL.Transaction- ) where+module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where -import Squeal.PostgreSQL.Binary-import Squeal.PostgreSQL.Definition-import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Manipulation-import Squeal.PostgreSQL.PQ-import Squeal.PostgreSQL.Query-import Squeal.PostgreSQL.Schema-import Squeal.PostgreSQL.Transaction+import Squeal.PostgreSQL.Alias as X+import Squeal.PostgreSQL.Binary as X+import Squeal.PostgreSQL.Definition as X+import Squeal.PostgreSQL.Expression as X+import Squeal.PostgreSQL.Expression.Aggregate as X+import Squeal.PostgreSQL.Expression.Collection as X+import Squeal.PostgreSQL.Expression.Comparison as X+import Squeal.PostgreSQL.Expression.Json as X+import Squeal.PostgreSQL.Expression.Literal as X+import Squeal.PostgreSQL.Expression.Logic as X+import Squeal.PostgreSQL.Expression.Math as X+import Squeal.PostgreSQL.Expression.Null as X+import Squeal.PostgreSQL.Expression.Parameter as X+import Squeal.PostgreSQL.Expression.SetOf as X+import Squeal.PostgreSQL.Expression.Sort as X+import Squeal.PostgreSQL.Expression.Subquery as X+import Squeal.PostgreSQL.Expression.Text as X+import Squeal.PostgreSQL.Expression.TextSearch as X+import Squeal.PostgreSQL.Expression.Time as X+import Squeal.PostgreSQL.Expression.Type as X+import Squeal.PostgreSQL.Expression.Window as X+import Squeal.PostgreSQL.List as X+import Squeal.PostgreSQL.Manipulation as X+import Squeal.PostgreSQL.Migration as X+import Squeal.PostgreSQL.PG as X+import Squeal.PostgreSQL.PQ as X+import Squeal.PostgreSQL.Query as X+import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)+import Squeal.PostgreSQL.Schema as X+import Squeal.PostgreSQL.Transaction as X
+ src/Squeal/PostgreSQL/Alias.hs view
@@ -0,0 +1,249 @@+{-|+Module: Squeal.PostgreSQL.Alias+Description: Aliases+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++This module embeds Postgres's alias system in Haskell in+a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,+Squeal can reference aliases by prepending with a @#@.+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilyDependencies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Alias+ ( (:::)+ , Alias (..)+ , IsLabel (..)+ , Aliased (As)+ , Aliasable (as)+ , renderAliased+ , Has+ , HasUnique+ , HasAll+ , HasIn+ , QualifiedAlias (..)+ , IsQualified (..)+ -- * Grouping+ , Grouping (..)+ , GroupedBy+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.String (fromString)+import GHC.OverloadedLabels+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Render++-- $setup+-- >>> import Squeal.PostgreSQL++-- | The alias operator `:::` is like a promoted version of `As`,+-- a type level pair between an alias and some type.+type (:::) (alias :: Symbol) ty = '(alias,ty)+infixr 6 :::+++-- | `Grouping` is an auxiliary namespace, created by+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used+-- for typesafe aggregation+data Grouping+ = Ungrouped -- ^ no aggregation permitted+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped++{- | A `GroupedBy` constraint indicates that a table qualified column is+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.+-}+class (KnownSymbol table, KnownSymbol column)+ => GroupedBy table column bys where+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)+ => GroupedBy table column ('(table,column) ': bys)+instance {-# OVERLAPPABLE #-}+ ( KnownSymbol table+ , KnownSymbol column+ , GroupedBy table column bys+ ) => GroupedBy table column (tabcol ': bys)++-- | `Alias`es are proxies for a type level string or `Symbol`+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@+--+-- >>> :set -XOverloadedLabels+-- >>> #foobar :: Alias "foobar"+-- Alias+data Alias (alias :: Symbol) = Alias+ deriving (Eq,GHC.Generic,Ord,Show,NFData)+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where+ fromLabel = Alias+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where+ fromLabel = fromLabel SOP.:* Nil+-- | >>> printSQL (#jimbob :: Alias "jimbob")+-- "jimbob"+instance KnownSymbol alias => RenderSQL (Alias alias) where+ renderSQL = doubleQuoted . fromString . symbolVal++-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])+-- "jimbob", "kandi"+instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where+ renderSQL+ = commaSeparated+ . SOP.hcollapse+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)++-- | The `As` operator is used to name an expression. `As` is like a demoted+-- version of `:::`.+--+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)+-- As (Just "hello") Alias+data Aliased expression aliased where+ As+ :: KnownSymbol alias+ => expression ty+ -> Alias alias+ -> Aliased expression (alias ::: ty)+deriving instance Show (expression ty)+ => Show (Aliased expression (alias ::: ty))+deriving instance Eq (expression ty)+ => Eq (Aliased expression (alias ::: ty))+deriving instance Ord (expression ty)+ => Ord (Aliased expression (alias ::: ty))+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1++-- | The `Aliasable` class provides a way to scrap your `Nil`s+-- in an `NP` list of `Aliased` expressions.+class KnownSymbol alias => Aliasable alias expression aliased+ | aliased -> expression+ , aliased -> alias+ where as :: expression -> Alias alias -> aliased+instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias+ (expression ty)+ (Aliased expression aliased)+ where+ as = As+instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias+ (expression ty)+ (NP (Aliased expression) tys)+ where+ expression `as` alias = expression `As` alias SOP.:* Nil++-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")+-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)+-- "Just AS \"an_int\""+renderAliased+ :: (forall ty. expression ty -> ByteString)+ -> Aliased expression aliased+ -> ByteString+renderAliased render (expression `As` alias) =+ render expression <> " AS " <> renderSQL alias++-- | @HasUnique alias fields field@ is a constraint that proves that+-- @fields@ is a singleton of @alias ::: field@.+type HasUnique alias fields field = fields ~ '[alias ::: field]++-- | @Has alias fields field@ is a constraint that proves that+-- @fields@ has a field of @alias ::: field@, inferring @field@+-- from @alias@ and @fields@.+class KnownSymbol alias =>+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)+ | alias fields -> field where+instance {-# OVERLAPPING #-} KnownSymbol alias+ => Has alias (alias ::: field ': fields) field+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)+ => Has 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+choose which subfields to update.+-}+class HasIn fields field where+instance (Has alias fields field) => HasIn fields (alias ::: field) where++-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer+-- a list of @subfields@.+class+ ( SOP.All KnownSymbol aliases+ ) => HasAll+ (aliases :: [Symbol])+ (fields :: [(Symbol,kind)])+ (subfields :: [(Symbol,kind)])+ | aliases fields -> subfields where+instance {-# OVERLAPPING #-} HasAll '[] fields '[]+instance {-# OVERLAPPABLE #-}+ (Has alias fields field, HasAll aliases fields subfields)+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)++-- | Analagous to `IsLabel`, the constraint+-- `IsQualified` defines `!` for a column alias qualified+-- by a table alias.+class IsQualified table column expression where+ (!) :: Alias table -> Alias column -> expression+ infixl 9 !+instance IsQualified table column (Alias table, Alias column) where (!) = (,)++{-| `QualifiedAlias`es enables multi-schema support by allowing a reference+to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`+or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,+a qualifier of @public@ is provided.++>>> :{+let+ alias1 :: QualifiedAlias "sch" "tab"+ alias1 = #sch ! #tab+ alias2 :: QualifiedAlias "public" "vw"+ alias2 = #vw+in printSQL alias1 >> printSQL alias2+:}+"sch"."tab"+"vw"+-}+data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias+ deriving (Eq,GHC.Generic,Ord,Show,NFData)+instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where+ _!_ = QualifiedAlias+instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where+ fromLabel = QualifiedAlias+instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>+ IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where+ _!_ = QualifiedAlias `As` Alias+instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>+ IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where+ fromLabel = QualifiedAlias `As` Alias++instance (KnownSymbol q, KnownSymbol a)+ => RenderSQL (QualifiedAlias q a) where+ renderSQL _ =+ let+ qualifier = renderSQL (Alias @q)+ alias = renderSQL (Alias @a)+ in+ if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
src/Squeal/PostgreSQL/Binary.hs view
@@ -7,7 +7,7 @@ This module provides binary encoding and decoding between Haskell and PostgreSQL types. -Instances are governed by the `Generic` and `HasDatatypeInfo` typeclasses, so you absolutely+Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely do not need to define your own instances to decode retrieved rows into Haskell values or to encode Haskell values into statement parameters. @@ -16,10 +16,10 @@ >>> import Data.Int (Int16) >>> import Data.Text (Text) >>> import Control.Monad (void)->>> import Control.Monad.Base (liftBase)+>>> import Control.Monad.IO.Class (liftIO) >>> import Squeal.PostgreSQL -Define a Haskell datatype `Row` that will serve as both the input and output of a simple+Define a Haskell datatype @Row@ that will serve as both the input and output of a simple round trip query. >>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)@@ -27,7 +27,7 @@ >>> instance HasDatatypeInfo Row >>> :{ let- roundTrip :: Query '[] (TuplePG Row) (RowPG Row)+ roundTrip :: Query_ (Public '[]) Row Row roundTrip = values_ $ parameter @1 int2 `as` #col1 :* parameter @2 text `as` #col2 :*@@ -39,15 +39,15 @@ >>> let input = Row 2 "hi" (Just True) >>> :{-void . withConnection "host=localhost port=5432 dbname=exampledb" $ do+withConnection "host=localhost port=5432 dbname=exampledb" $ do result <- runQueryParams roundTrip input Just output <- firstRow result- liftBase . print $ input == output+ liftIO . print $ input == output :} True In addition to being able to encode and decode basic Haskell types-like `Int16` and `Text`, Squeal permits you to encode and decode Haskell types to+like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to Postgres array, enumerated and composite types and json. Let's see another example, this time using the `Vector` type which corresponds to variable length arrays and homogeneous tuples which correspond to fixed length arrays. We can even@@ -55,9 +55,9 @@ >>> :{ data Row = Row- { col1 :: Vector Int16- , col2 :: (Maybe Int16,Maybe Int16)- , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))+ { col1 :: VarArray (Vector Int16)+ , col2 :: FixArray (Maybe Int16,Maybe Int16)+ , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16)) } deriving (Eq, GHC.Generic) :} @@ -68,20 +68,20 @@ >>> :{ let- roundTrip :: Query '[] (TuplePG Row) (RowPG Row)+ roundTrip :: Query_ (Public '[]) Row Row roundTrip = values_ $- parameter @1 (int2 & vararray) `as` #col1 :*- parameter @2 (int2 & fixarray @2) `as` #col2 :*- parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3+ parameter @1 (int2 & vararray) `as` #col1 :*+ parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*+ parameter @3 (int2 & fixarray @'[3,2]) `as` #col3 :} >>> :set -XOverloadedLists->>> let input = Row [1,2] (Just 1,Nothing) ((1,2),(3,4),(5,6))+>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6))) >>> :{-void . withConnection "host=localhost port=5432 dbname=exampledb" $ do+withConnection "host=localhost port=5432 dbname=exampledb" $ do result <- runQueryParams roundTrip input Just output <- firstRow result- liftBase . print $ input == output+ liftIO . print $ input == output :} True @@ -114,15 +114,15 @@ >>> :{ let- setup :: Definition '[] Schema+ setup :: Definition (Public '[]) (Public Schema) setup = createTypeEnumFrom @Schwarma #schwarma >>> createTypeCompositeFrom @Person #person :} -Let's demonstrate how to associate our Haskell types `Schwarma` and `Person`+Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@ with enumerated, composite or json types in Postgres. First create a Haskell-`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.+@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields. >>> :{ data Row = Row@@ -146,7 +146,7 @@ >>> :{ let- roundTrip :: Query Schema (TuplePG Row) (RowPG Row)+ roundTrip :: Query_ (Public Schema) Row Row roundTrip = values_ $ parameter @1 (typedef #schwarma) `as` #schwarma :* parameter @2 (typedef #person) `as` #person1 :*@@ -157,7 +157,7 @@ >>> :{ let- teardown :: Definition Schema '[]+ teardown :: Definition (Public Schema) (Public '[]) teardown = dropType #schwarma >>> dropType #person :} @@ -168,9 +168,9 @@ session = do result <- runQueryParams roundTrip input Just output <- firstRow result- liftBase . print $ input == output+ liftIO . print $ input == output in- void . withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb" $ define setup & pqThen session & pqThen (define teardown)@@ -194,20 +194,30 @@ , MultiParamTypeClasses , ScopedTypeVariables , TypeApplications+ , TypeFamilies , TypeInType , TypeOperators , UndecidableInstances+ , UndecidableSuperClasses #-} module Squeal.PostgreSQL.Binary ( -- * Encoding ToParam (..) , ToParams (..)+ , ToNullityParam (..)+ , ToField (..)+ , ToFixArray (..) -- * Decoding , FromValue (..) , FromRow (..)+ , FromField (..)+ , FromFixArray (..) -- * Only , Only (..)+ -- * Oid+ , HasOid (..)+ , HasAliasedOid (..) ) where import BinaryParser@@ -238,6 +248,9 @@ import qualified PostgreSQL.Binary.Decoding as Decoding import qualified PostgreSQL.Binary.Encoding as Encoding +import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.PG import Squeal.PostgreSQL.Schema -- | A `ToParam` constraint gives an encoding of a Haskell `Type` into@@ -269,6 +282,7 @@ instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4 instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8 instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric+instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8@@ -297,16 +311,25 @@ instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where toParam = K . Encoding.jsonb_bytes . Lazy.ByteString.toStrict . Aeson.encode . getJsonb-instance ToArray x ('NotNull ('PGvararray ty))- => ToParam x ('PGvararray ty) where- toParam- = K . Encoding.array (baseOid @x @('NotNull ('PGvararray ty)))- . unK . toArray @x @('NotNull ('PGvararray ty))-instance ToArray x ('NotNull ('PGfixarray n ty))- => ToParam x ('PGfixarray n ty) where- toParam- = K . Encoding.array (baseOid @x @('NotNull ('PGfixarray n ty)))- . unK . toArray @x @('NotNull ('PGfixarray n ty))+instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)+ => ToParam (VarArray [x]) ('PGvararray ty) where+ toParam = K+ . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)+ . getVarArray+instance (ToParam x pg, HasOid pg)+ => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where+ toParam = K+ . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)+ . getVarArray+instance (ToParam x pg, HasOid pg)+ => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where+ toParam = K+ . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)+ . getVarArray+instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)+ => ToParam (FixArray x) ('PGfixarray dims ty) where+ toParam = K . Encoding.array (oid @pg)+ . unK . unK . toFixArray @x @dims @ty . getFixArray instance ( IsEnumType x , HasDatatypeInfo x@@ -371,11 +394,42 @@ in composite . encoders . toRecord . getComposite +-- | The object identifier of a `PGType`.+--+-- >>> :set -XTypeApplications+-- >>> oid @'PGbool+-- 16+class HasOid (ty :: PGType) where oid :: Word32+instance HasOid 'PGbool where oid = 16+instance HasOid 'PGint2 where oid = 21+instance HasOid 'PGint4 where oid = 23+instance HasOid 'PGint8 where oid = 20+instance HasOid 'PGnumeric where oid = 1700+instance HasOid 'PGfloat4 where oid = 700+instance HasOid 'PGfloat8 where oid = 701+instance HasOid ('PGchar n) where oid = 18+instance HasOid ('PGvarchar n) where oid = 1043+instance HasOid 'PGtext where oid = 25+instance HasOid 'PGbytea where oid = 17+instance HasOid 'PGtimestamp where oid = 1114+instance HasOid 'PGtimestamptz where oid = 1184+instance HasOid 'PGdate where oid = 1082+instance HasOid 'PGtime where oid = 1083+instance HasOid 'PGtimetz where oid = 1266+instance HasOid 'PGinterval where oid = 1186+instance HasOid 'PGuuid where oid = 2950+instance HasOid 'PGinet where oid = 869+instance HasOid 'PGjson where oid = 114+instance HasOid 'PGjsonb where oid = 3802++-- | Lifts a `HasOid` constraint to a field. class HasAliasedOid (field :: (Symbol, NullityType)) where aliasedOid :: Word32 instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where aliasedOid = oid @ty +-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into+-- into the binary format of a PostgreSQL `NullityType`. class ToNullityParam (x :: Type) (ty :: NullityType) where toNullityParam :: x -> K (Maybe Encoding.Encoding) ty instance ToParam x pg => ToNullityParam x ('NotNull pg) where@@ -383,55 +437,36 @@ instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where toNullityParam = K . fmap (unK . toParam @x @pg) +-- | A `ToField` constraint lifts the `ToParam` parser+-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,+-- encoding `Null`s to `Maybe`s. You should not define instances for+-- `FromField`, just use the provided instances. class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where toField :: P x -> K (Maybe Encoding.Encoding) field instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where toField (P x) = K . unK $ toNullityParam @x @ty x -class ToArray (x :: Type) (array :: NullityType) where- toArray :: x -> K Encoding.Array array- baseOid :: Word32- default baseOid :: HasOid (PGTypeOf array) => Word32- baseOid = oid @(PGTypeOf array)-instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)- => ToArray x ('NotNull pg) where- toArray = K . Encoding.encodingArray . unK . toParam @x @pg-instance {-# OVERLAPPABLE #-} (HasOid pg, ToParam x pg)- => ToArray (Maybe x) ('Null pg) where- toArray = K . maybe Encoding.nullArray- (Encoding.encodingArray . unK . toParam @x @pg)-instance {-# OVERLAPPING #-} ToArray x array- => ToArray (Vector x) ('NotNull ('PGvararray array)) where- toArray = K . Encoding.dimensionArray Vector.foldl'- (unK . toArray @x @array)- baseOid = baseOid @x @array-instance {-# OVERLAPPING #-} ToArray x array- => ToArray (Maybe (Vector x)) ('Null ('PGvararray array)) where- toArray = K . maybe Encoding.nullArray- (Encoding.dimensionArray Vector.foldl' (unK . toArray @x @array))- baseOid = baseOid @x @array-instance {-# OVERLAPPING #-}- ( IsProductType product xs- , Length xs ~ n- , All ((~) x) xs- , ToArray x array )- => ToArray product ('NotNull ('PGfixarray n array)) where- toArray = K . Encoding.dimensionArray foldlN- (unK . toArray @x @array) . unZ . unSOP . from- baseOid = baseOid @x @array-instance {-# OVERLAPPING #-}+-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`+-- into the binary format of a PostgreSQL fixed-length array.+-- You should not define instances for+-- `ToFixArray`, just use the provided instances.+class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where+ toFixArray :: x -> K (K Encoding.Array dims) array+instance ToNullityParam x ty => ToFixArray x '[] ty where+ toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK+ . toNullityParam @x @ty+instance ( IsProductType product xs- , Length xs ~ n+ , Length xs ~ dim , All ((~) x) xs- , ToArray x array )- => ToArray (Maybe product) ('Null ('PGfixarray n array)) where- toArray = K . maybe Encoding.nullArray- (Encoding.dimensionArray foldlN (unK . toArray @x @array) . unZ . unSOP . from)- baseOid = baseOid @x @array+ , ToFixArray x dims ty )+ => ToFixArray product (dim ': dims) ty where+ toFixArray = K . K . Encoding.dimensionArray foldlN+ (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from -- | A `ToParams` constraint generically sequences the encodings of `Type`s -- of the fields of a tuple or record to a row of `ColumnType`s. You should--- not define instances of `ToParams`. Instead define `Generic` instances+-- not define instances of `ToParams`. Instead define `SOP.Generic` instances -- which in turn provide `ToParams` instances. class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]@@ -463,6 +498,7 @@ instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4 instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8 instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric+instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet instance FromValue ('PGchar 1) Char where fromValue = Decoding.char@@ -492,12 +528,41 @@ instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where fromValue = Jsonb <$> Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)-instance FromArray ('NotNull ('PGvararray ty)) y- => FromValue ('PGvararray ty) y where- fromValue = Decoding.array (fromArray @('NotNull ('PGvararray ty)) @y)-instance FromArray ('NotNull ('PGfixarray n ty)) y- => FromValue ('PGfixarray n ty) y where- fromValue = Decoding.array (fromArray @('NotNull ('PGfixarray n ty)) @y)+instance FromValue pg y+ => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where+ fromValue =+ let+ rep n x = VarArray <$> Vector.replicateM n x+ in+ Decoding.array $ Decoding.dimensionArray rep+ (fromFixArray @'[] @('NotNull pg))+instance FromValue pg y+ => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where+ fromValue =+ let+ rep n x = VarArray <$> Vector.replicateM n x+ in+ Decoding.array $ Decoding.dimensionArray rep+ (fromFixArray @'[] @('Null pg))+instance FromValue pg y+ => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where+ fromValue =+ let+ rep n x = VarArray <$> replicateM n x+ in+ Decoding.array $ Decoding.dimensionArray rep+ (fromFixArray @'[] @('NotNull pg))+instance FromValue pg y+ => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where+ fromValue =+ let+ rep n x = VarArray <$> replicateM n x+ in+ Decoding.array $ Decoding.dimensionArray rep+ (fromFixArray @'[] @('Null pg))+instance FromFixArray dims ty y+ => FromValue ('PGfixarray dims ty) (FixArray y) where+ fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y) instance ( IsEnumType y , HasDatatypeInfo y@@ -568,49 +633,32 @@ K (Just bytestring) -> P . Just <$> Decoding.valueParser (fromValue @pg) bytestring -class FromArray (ty :: NullityType) (y :: Type) where- fromArray :: Decoding.Array y-instance {-# OVERLAPPABLE #-} FromValue pg y- => FromArray ('NotNull pg) y where- fromArray = Decoding.valueArray (fromValue @pg @y)-instance {-# OVERLAPPABLE #-} FromValue pg y- => FromArray ('Null pg) (Maybe y) where- fromArray = Decoding.nullableValueArray (fromValue @pg @y)-instance {-# OVERLAPPING #-} FromArray array y- => FromArray ('NotNull ('PGvararray array)) (Vector y) where- fromArray =- Decoding.dimensionArray Vector.replicateM (fromArray @array @y)-instance {-# OVERLAPPING #-} FromArray array y- => FromArray ('Null ('PGvararray array)) (Maybe (Vector y)) where- fromArray = Just <$> - Decoding.dimensionArray Vector.replicateM (fromArray @array @y)-instance {-# OVERLAPPING #-}- ( FromArray array y- , All ((~) y) ys- , SListI ys- , IsProductType product ys )- => FromArray ('NotNull ('PGfixarray n array)) product where- fromArray =- let- rep _ = fmap (to . SOP . Z) . replicateMN- in- Decoding.dimensionArray rep (fromArray @array @y)-instance {-# OVERLAPPING #-}- ( FromArray array y+-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`+-- from the binary format of a PostgreSQL fixed-length array.+-- You should not define instances for+-- `FromFixArray`, just use the provided instances.+class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where+ fromFixArray :: Decoding.Array y+instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where+ fromFixArray = Decoding.valueArray (fromValue @pg @y)+instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where+ fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)+instance+ ( IsProductType product ys+ , Length ys ~ dim , All ((~) y) ys- , SListI ys- , IsProductType product ys )- => FromArray ('Null ('PGfixarray n array)) (Maybe product) where- fromArray =+ , FromFixArray dims ty y )+ => FromFixArray (dim ': dims) ty product where+ fromFixArray = let rep _ = fmap (to . SOP . Z) . replicateMN in- Just <$> Decoding.dimensionArray rep (fromArray @array @y)+ Decoding.dimensionArray rep (fromFixArray @dims @ty @y) -- | A `FromRow` constraint generically sequences the parsings of the columns -- of a `RowType` into the fields of a record `Type` provided they have -- the same field names. You should not define instances of `FromRow`.--- Instead define `Generic` and `HasDatatypeInfo` instances which in turn+-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn -- provide `FromRow` instances. class SListI result => FromRow (result :: RowType) y where -- | >>> :set -XOverloadedStrings@@ -633,6 +681,53 @@ = fmap fromRecord . hsequence' . htrans (Proxy @FromField) fromField+------------------------------------------------------+-- P records+------------------------------------------------------+-- instance (FromField (col ::: pg) (col ::: hask))+-- => FromRow '[col ::: pg] (P (col ::: hask)) where+-- fromRow (pg :* Nil) = (unComp . fromField) pg+-- instance+-- ( row ~ Join row1 row2+-- , FromRow row1 hask1+-- , FromRow row2 hask2+-- , SListI row+-- ) => FromRow row (hask1, hask2) where+-- fromRow row = case disjoin @row1 @row2 row of+-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2+-- instance+-- ( row ~ Join row1 row23+-- , FromRow row1 hask1+-- , FromRow row23 (hask2, hask3)+-- , SListI row+-- ) => FromRow row (hask1, hask2, hask3) where+-- fromRow row = case disjoin @row1 @row23 row of+-- (row1, row23) -> do+-- hask1 <- fromRow row1+-- (hask2, hask3) <- fromRow row23+-- return (hask1, hask2, hask3)+-- instance+-- ( row ~ Join row1 row234+-- , FromRow row1 hask1+-- , FromRow row234 (hask2, hask3, hask4)+-- , SListI row+-- ) => FromRow row (hask1, hask2, hask3, hask4) where+-- fromRow row = case disjoin @row1 @row234 row of+-- (row1, row234) -> do+-- hask1 <- fromRow row1+-- (hask2, hask3, hask4) <- fromRow row234+-- return (hask1, hask2, hask3, hask4)+-- instance+-- ( row ~ Join row1 row2345+-- , FromRow row1 hask1+-- , FromRow row2345 (hask2, hask3, hask4, hask5)+-- , SListI row+-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where+-- fromRow row = case disjoin @row1 @row2345 row of+-- (row1, row2345) -> do+-- hask1 <- fromRow row1+-- (hask2, hask3, hask4, hask5) <- fromRow row2345+-- return (hask1, hask2, hask3, hask4, hask5) -- | `Only` is a 1-tuple type, useful for encoding a single parameter with -- `toParams` or decoding a single value with `fromRow`.@@ -659,4 +754,4 @@ :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs) => m x -> m (NP I xs) replicateMN mx = hsequence' $- hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx)) + hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
src/Squeal/PostgreSQL/Definition.hs view
@@ -29,49 +29,51 @@ module Squeal.PostgreSQL.Definition ( -- * Definition- Definition (UnsafeDefinition, renderDefinition)+ Definition (..) , (>>>)+ , manipDefinition -- * Tables -- ** Create+ , createSchema+ , createSchemaIfNotExists , createTable , createTableIfNotExists+ , createView+ , createTypeEnum+ , createTypeEnumFrom+ , createTypeComposite+ , createTypeCompositeFrom+ , FieldTyped (..)+ , createDomain , TableConstraintExpression (..) , check , unique , primaryKey , foreignKey , ForeignKeyed- , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)- , renderOnDeleteClause- , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)- , renderOnUpdateClause+ , OnDeleteClause (..)+ , OnUpdateClause (..) -- ** Drop+ , dropSchema , dropTable+ , dropView+ , dropType -- ** Alter , alterTable , alterTableRename- , AlterTable (UnsafeAlterTable, renderAlterTable)+ , AlterTable (..) , addConstraint , dropConstraint- , AddColumn (addColumn)+ , AddColumn (..) , dropColumn , renameColumn , alterColumn- , AlterColumn (UnsafeAlterColumn, renderAlterColumn)+ , AlterColumn (..) , setDefault , dropDefault , setNotNull , dropNotNull , alterType- -- * Views- , createView- , dropView- -- * Types- , createTypeEnum- , createTypeEnumFrom- , createTypeComposite- , createTypeCompositeFrom- , dropType -- * Columns , ColumnTypeExpression (..) , nullable@@ -95,36 +97,80 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC +import Squeal.PostgreSQL.Alias import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.PG import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Manipulation import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Schema +-- $setup+-- >>> import Squeal.PostgreSQL+ {----------------------------------------- statements -----------------------------------------} --- | A `Definition` is a statement that changes the schema of the+-- | A `Definition` is a statement that changes the schemas of the -- database, like a `createTable`, `dropTable`, or `alterTable` command. -- `Definition`s may be composed using the `>>>` operator. newtype Definition- (schema0 :: SchemaType)- (schema1 :: SchemaType)+ (schemas0 :: SchemasType)+ (schemas1 :: SchemasType) = UnsafeDefinition { renderDefinition :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData) -instance RenderSQL (Definition schema0 schema1) where+instance RenderSQL (Definition schemas0 schemas1) where renderSQL = renderDefinition instance Category Definition where id = UnsafeDefinition ";" ddl1 . ddl0 = UnsafeDefinition $- renderDefinition ddl0 <> "\n" <> renderDefinition ddl1+ renderSQL ddl0 <> "\n" <> renderSQL ddl1 +-- | A `Manipulation` without input or output can be run as a statement+-- along with other `Definition`s, by embedding it using `manipDefinition`.+manipDefinition+ :: Manipulation '[] schemas '[] '[]+ -- ^ no input or output+ -> Definition schemas schemas+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL+ {----------------------------------------- CREATE statements -----------------------------------------} +{- |+`createSchema` enters a new schema into the current database.+The schema name must be distinct from the name of any existing schema+in the current database.++A schema is essentially a namespace: it contains named objects+(tables, data types, functions, and operators) whose names+can duplicate those of other objects existing in other schemas.+Named objects are accessed by `QualifiedAlias`es with the schema+name as a prefix.+-}+createSchema+ :: KnownSymbol sch+ => Alias sch+ -> Definition schemas (Create sch '[] schemas)+createSchema sch = UnsafeDefinition $+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"++{- | Idempotent version of `createSchema`. -}+createSchemaIfNotExists+ :: (KnownSymbol sch, Has sch schemas schema)+ => Alias sch+ -> Definition schemas schemas+createSchemaIfNotExists sch = UnsafeDefinition $+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"+ <+> renderSQL sch <> ";"+ {- | `createTable` adds a table to the schema. >>> :set -XOverloadedLabels@@ -136,7 +182,7 @@ >>> :{ let- setup :: Definition '[] '["tab" ::: 'Table Table]+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table]) setup = createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil in printSQL setup@@ -144,17 +190,19 @@ CREATE TABLE "tab" ("a" int NULL, "b" real NULL); -} createTable- :: ( KnownSymbol table+ :: ( KnownSymbol sch+ , KnownSymbol tab , columns ~ (col ': cols) , SOP.SListI columns , SOP.SListI constraints- , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )- => Alias table -- ^ the name of the table to add- -> NP (Aliased (ColumnTypeExpression schema0)) columns+ , Has sch schemas0 schema0+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )+ => QualifiedAlias sch tab -- ^ the name of the table to add+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns -- ^ the names and datatype of each column- -> NP (Aliased (TableConstraintExpression schema1 table)) constraints+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints -- ^ constraints that must hold for the table- -> Definition schema0 schema1+ -> Definition schemas0 schemas1 createTable tab columns constraints = UnsafeDefinition $ "CREATE TABLE" <+> renderCreation tab columns constraints @@ -170,11 +218,11 @@ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ] :} ->>> type Schema = '["tab" ::: 'Table Table]+>>> type Schemas = Public '["tab" ::: 'Table Table] >>> :{ let- setup :: Definition Schema Schema+ setup :: Definition Schemas Schemas setup = createTableIfNotExists #tab (nullable int `as` #a :* nullable real `as` #b) Nil in printSQL setup@@ -182,31 +230,33 @@ CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL); -} createTableIfNotExists- :: ( Has table schema ('Table (constraints :=> columns))+ :: ( Has sch schemas schema+ , Has tab schema ('Table (constraints :=> columns)) , SOP.SListI columns , SOP.SListI constraints )- => Alias table -- ^ the name of the table to add- -> NP (Aliased (ColumnTypeExpression schema)) columns+ => QualifiedAlias sch tab -- ^ the name of the table to add+ -> NP (Aliased (ColumnTypeExpression schemas)) columns -- ^ the names and datatype of each column- -> NP (Aliased (TableConstraintExpression schema table)) constraints+ -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints -- ^ constraints that must hold for the table- -> Definition schema schema+ -> Definition schemas schemas createTableIfNotExists tab columns constraints = UnsafeDefinition $ "CREATE TABLE IF NOT EXISTS" <+> renderCreation tab columns constraints -- helper function for `createTable` and `createTableIfNotExists` renderCreation- :: ( KnownSymbol table+ :: ( KnownSymbol sch+ , KnownSymbol tab , SOP.SListI columns , SOP.SListI constraints )- => Alias table -- ^ the name of the table to add- -> NP (Aliased (ColumnTypeExpression schema0)) columns+ => QualifiedAlias sch tab -- ^ the name of the table to add+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns -- ^ the names and datatype of each column- -> NP (Aliased (TableConstraintExpression schema1 table)) constraints+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints -- ^ constraints that must hold for the table -> ByteString-renderCreation tab columns constraints = renderAlias tab+renderCreation tab columns constraints = renderSQL tab <+> parenthesized ( renderCommaSeparated renderColumnDef columns <> ( case constraints of@@ -215,14 +265,14 @@ renderCommaSeparated renderConstraint constraints ) ) <> ";" where- renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString renderColumnDef (ty `As` column) =- renderAlias column <+> renderColumnTypeExpression ty+ renderSQL column <+> renderColumnTypeExpression ty renderConstraint- :: Aliased (TableConstraintExpression schema columns) constraint+ :: Aliased (TableConstraintExpression sch tab schemas) constraint -> ByteString renderConstraint (constraint `As` alias) =- "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint -- | Data types are a way to limit the kind of data that can be stored in a -- table. For many applications, however, the constraint they provide is@@ -237,12 +287,16 @@ -- violate a constraint, an error is raised. This applies -- even if the value came from the default value definition. newtype TableConstraintExpression- (schema :: SchemaType)- (table :: Symbol)- (tableConstraint :: TableConstraint)+ (sch :: Symbol)+ (tab :: Symbol)+ (schemas :: SchemasType)+ (constraint :: TableConstraint) = UnsafeTableConstraintExpression { renderTableConstraintExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL+ (TableConstraintExpression sch tab schemas constraint) where+ renderSQL = renderTableConstraintExpression {-| A `check` constraint is the most generic `TableConstraint` type. It allows you to specify that the value in a certain column must satisfy@@ -258,7 +312,7 @@ >>> :{ let- definition :: Definition '[] Schema+ definition :: Definition (Public '[]) (Public Schema) definition = createTable #tab ( (int & notNullable) `as` #a :* (int & notNullable) `as` #b )@@ -269,15 +323,16 @@ CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b"))); -} check- :: ( Has alias schema ('Table table)+ :: ( Has sch schemas schema+ , Has tab schema ('Table table) , HasAll aliases (TableToRow table) subcolumns ) => NP Alias aliases -- ^ specify the subcolumns which are getting checked- -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[])+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns]) -- ^ a closed `Condition` on those subcolumns- -> TableConstraintExpression schema alias ('Check aliases)+ -> TableConstraintExpression sch tab schemas ('Check aliases) check _cols condition = UnsafeTableConstraintExpression $- "CHECK" <+> parenthesized (renderExpression condition)+ "CHECK" <+> parenthesized (renderSQL condition) {-| A `unique` constraint ensure that the data contained in a column, or a group of columns, is unique among all the rows in the table.@@ -292,7 +347,7 @@ >>> :{ let- definition :: Definition '[] Schema+ definition :: Definition (Public '[]) (Public Schema) definition = createTable #tab ( (int & nullable) `as` #a :* (int & nullable) `as` #b )@@ -303,13 +358,14 @@ CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b")); -} unique- :: ( Has alias schema ('Table table)+ :: ( Has sch schemas schema+ , Has tab schema('Table table) , HasAll aliases (TableToRow table) subcolumns ) => NP Alias aliases -- ^ specify subcolumns which together are unique for each row- -> TableConstraintExpression schema alias ('Unique aliases)+ -> TableConstraintExpression sch tab schemas ('Unique aliases) unique columns = UnsafeTableConstraintExpression $- "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))+ "UNIQUE" <+> parenthesized (renderSQL columns) {-| A `primaryKey` constraint indicates that a column, or group of columns, can be used as a unique identifier for rows in the table.@@ -325,7 +381,7 @@ >>> :{ let- definition :: Definition '[] Schema+ definition :: Definition (Public '[]) (Public Schema) definition = createTable #tab ( serial `as` #id :* (text & notNullable) `as` #name )@@ -336,14 +392,15 @@ CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id")); -} primaryKey- :: ( Has alias schema ('Table table)+ :: ( Has sch schemas schema+ , Has tab schema ('Table table) , HasAll aliases (TableToColumns table) subcolumns , AllNotNull subcolumns ) => NP Alias aliases -- ^ specify the subcolumns which together form a primary key.- -> TableConstraintExpression schema alias ('PrimaryKey aliases)+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases) primaryKey columns = UnsafeTableConstraintExpression $- "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))+ "PRIMARY KEY" <+> parenthesized (renderSQL columns) {-| A `foreignKey` specifies that the values in a column (or a group of columns) must match the values appearing in some row of@@ -370,7 +427,7 @@ >>> :{ let- setup :: Definition '[] Schema+ setup :: Definition (Public '[]) (Public Schema) setup = createTable #users ( serial `as` #id :*@@ -405,7 +462,7 @@ >>> :{ let- setup :: Definition '[] Schema+ setup :: Definition (Public '[]) (Public Schema) setup = createTable #employees ( serial `as` #id :*@@ -419,7 +476,7 @@ 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 schema child parent+ :: (ForeignKeyed schemas sch schema child parent table reftable columns refcolumns constraints cols@@ -434,23 +491,26 @@ -- ^ what to do when reference is deleted -> OnUpdateClause -- ^ what to do when reference is updated- -> TableConstraintExpression schema child+ -> TableConstraintExpression sch child schemas ('ForeignKey columns parent refcolumns) foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $- "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))- <+> "REFERENCES" <+> renderAlias parent- <+> parenthesized (commaSeparated (renderAliases refs))- <+> renderOnDeleteClause ondel- <+> renderOnUpdateClause onupd+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)+ <+> "REFERENCES" <+> renderSQL parent+ <+> parenthesized (renderSQL refs)+ <+> renderSQL ondel+ <+> renderSQL onupd -- | A constraint synonym between types involved in a foreign key constraint.-type ForeignKeyed schema+type ForeignKeyed schemas+ sch+ schema child parent table reftable columns refcolumns constraints cols reftys tys =- ( Has child schema ('Table table)+ ( Has sch schemas schema+ , Has child schema ('Table table) , Has parent schema ('Table reftable) , HasAll columns (TableToColumns table) tys , reftable ~ (constraints :=> cols)@@ -469,13 +529,12 @@ -- row(s) referencing it should be automatically deleted as well deriving (GHC.Generic,Show,Eq,Ord) instance NFData OnDeleteClause- -- | Render `OnDeleteClause`.-renderOnDeleteClause :: OnDeleteClause -> ByteString-renderOnDeleteClause = \case- OnDeleteNoAction -> "ON DELETE NO ACTION"- OnDeleteRestrict -> "ON DELETE RESTRICT"- OnDeleteCascade -> "ON DELETE CASCADE"+instance RenderSQL OnDeleteClause where+ renderSQL = \case+ OnDeleteNoAction -> "ON DELETE NO ACTION"+ OnDeleteRestrict -> "ON DELETE RESTRICT"+ OnDeleteCascade -> "ON DELETE CASCADE" -- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked -- when a referenced column is changed (updated).@@ -491,31 +550,46 @@ instance NFData OnUpdateClause -- | Render `OnUpdateClause`.-renderOnUpdateClause :: OnUpdateClause -> ByteString-renderOnUpdateClause = \case- OnUpdateNoAction -> "ON UPDATE NO ACTION"- OnUpdateRestrict -> "ON UPDATE RESTRICT"- OnUpdateCascade -> "ON UPDATE CASCADE"+instance RenderSQL OnUpdateClause where+ renderSQL = \case+ OnUpdateNoAction -> "ON UPDATE NO ACTION"+ OnUpdateRestrict -> "ON UPDATE RESTRICT"+ OnUpdateCascade -> "ON UPDATE CASCADE" {----------------------------------------- DROP statements -----------------------------------------} +-- | >>> :{+-- let+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]+-- definition = dropSchema #muh_schema+-- :}+--+-- >>> printSQL definition+-- DROP SCHEMA "muh_schema";+dropSchema+ :: Has sch schemas schema+ => Alias sch+ -> Definition schemas (Drop sch schemas)+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"+ -- | `dropTable` removes a table from the schema. -- -- >>> :{ -- let--- definition :: Definition '["muh_table" ::: 'Table t] '[]+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[]) -- definition = dropTable #muh_table -- :} -- -- >>> printSQL definition -- DROP TABLE "muh_table"; dropTable- :: Has table schema ('Table t)- => Alias table -- ^ table to remove- -> Definition schema (Drop table schema)-dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";"+ :: ( Has sch schemas schema+ , Has tab schema ('Table table))+ => QualifiedAlias sch tab -- ^ table to remove+ -> Definition schemas (Alter sch (Drop tab schema) schemas)+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";" {----------------------------------------- ALTER statements@@ -523,13 +597,13 @@ -- | `alterTable` changes the definition of a table from the schema. alterTable- :: KnownSymbol alias- => Alias alias -- ^ table to alter- -> AlterTable alias table schema -- ^ alteration to perform- -> Definition schema (Alter alias ('Table table) schema)+ :: (Has sch schemas schema, Has tab schema ('Table table0))+ => QualifiedAlias sch tab -- ^ table to alter+ -> AlterTable sch tab schemas table1 -- ^ alteration to perform+ -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas) alterTable tab alteration = UnsafeDefinition $ "ALTER TABLE"- <+> renderAlias tab+ <+> renderSQL tab <+> renderAlterTable alteration <> ";" @@ -543,15 +617,16 @@ -> Alias table1 -- ^ what to rename it -> Definition schema (Rename table0 table1 schema) alterTableRename table0 table1 = UnsafeDefinition $- "ALTER TABLE" <+> renderAlias table0- <+> "RENAME TO" <+> renderAlias table1 <> ";"+ "ALTER TABLE" <+> renderSQL table0+ <+> "RENAME TO" <+> renderSQL table1 <> ";" -- | An `AlterTable` describes the alteration to perform on the columns -- of a table. newtype AlterTable- (alias :: Symbol)- (table :: TableType)- (schema :: SchemaType) =+ (sch :: Symbol)+ (tab :: Symbol)+ (schemas :: SchemasType)+ (table :: TableType) = UnsafeAlterTable {renderAlterTable :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -560,46 +635,48 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]--- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] -- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0))) -- in printSQL definition -- :} -- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0)); addConstraint :: ( KnownSymbol alias+ , Has sch schemas schema , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (Create alias constraint constraints :=> columns) ) => Alias alias- -> TableConstraintExpression schema tab constraint+ -> TableConstraintExpression sch tab schemas constraint -- ^ constraint to add- -> AlterTable tab table1 schema+ -> AlterTable sch tab schemas table1 addConstraint alias constraint = UnsafeAlterTable $- "ADD" <+> "CONSTRAINT" <+> renderAlias alias- <+> renderTableConstraintExpression constraint+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias+ <+> renderSQL constraint -- | A `dropConstraint` drops a table constraint. -- -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] -- definition = alterTable #tab (dropConstraint #positive) -- in printSQL definition -- :} -- ALTER TABLE "tab" DROP CONSTRAINT "positive"; dropConstraint :: ( KnownSymbol constraint+ , Has sch schemas schema , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (Drop constraint constraints :=> columns) ) => Alias constraint -- ^ constraint to drop- -> AlterTable tab table1 schema+ -> AlterTable sch tab schemas table1 dropConstraint constraint = UnsafeAlterTable $- "DROP" <+> "CONSTRAINT" <+> renderAlias constraint+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint -- | An `AddColumn` is either @NULL@ or has @DEFAULT@. class AddColumn ty where@@ -609,10 +686,10 @@ -- >>> :{ -- let -- definition :: Definition- -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]- -- '["tab" ::: 'Table ('[] :=>+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4- -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]] -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo")) -- in printSQL definition -- :}@@ -621,24 +698,24 @@ -- >>> :{ -- let -- definition :: Definition- -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]- -- '["tab" ::: 'Table ('[] :=>+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4- -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]] -- definition = alterTable #tab (addColumn #col2 (text & nullable)) -- in printSQL definition -- :} -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL; addColumn :: ( KnownSymbol column+ , Has sch schemas schema , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns)- , table1 ~ (constraints :=> Create column ty columns) )+ , table0 ~ (constraints :=> columns) ) => Alias column -- ^ column to add- -> ColumnTypeExpression schema ty -- ^ type of the new column- -> AlterTable tab table1 schema+ -> ColumnTypeExpression schemas ty -- ^ type of the new column+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns) addColumn column ty = UnsafeAlterTable $- "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty) instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty) @@ -650,31 +727,32 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=>+-- '["public" ::: '["tab" ::: 'Table ('[] :=> -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4--- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]--- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]] -- definition = alterTable #tab (dropColumn #col2) -- in printSQL definition -- :} -- ALTER TABLE "tab" DROP COLUMN "col2"; dropColumn :: ( KnownSymbol column+ , Has sch schemas schema , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Drop column columns) ) => Alias column -- ^ column to remove- -> AlterTable tab table1 schema+ -> AlterTable sch tab schemas table1 dropColumn column = UnsafeAlterTable $- "DROP COLUMN" <+> renderAlias column+ "DROP COLUMN" <+> renderSQL column -- | A `renameColumn` renames a column. -- -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]] -- definition = alterTable #tab (renameColumn #foo #bar) -- in printSQL definition -- :}@@ -682,30 +760,32 @@ renameColumn :: ( KnownSymbol column0 , KnownSymbol column1+ , Has sch schemas schema , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , table1 ~ (constraints :=> Rename column0 column1 columns) ) => Alias column0 -- ^ column to rename -> Alias column1 -- ^ what to rename the column- -> AlterTable tab table1 schema+ -> AlterTable sch tab schemas table1 renameColumn column0 column1 = UnsafeAlterTable $- "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1 -- | An `alterColumn` alters a single column. alterColumn :: ( KnownSymbol column+ , Has sch schemas schema , Has tab schema ('Table table0) , table0 ~ (constraints :=> columns) , Has column columns ty0- , tables1 ~ (constraints :=> Alter column ty1 columns))+ , table1 ~ (constraints :=> Alter column ty1 columns)) => Alias column -- ^ column to alter- -> AlterColumn schema ty0 ty1 -- ^ alteration to perform- -> AlterTable tab table1 schema+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform+ -> AlterTable sch tab schemas table1 alterColumn column alteration = UnsafeAlterTable $- "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration -- | An `AlterColumn` describes the alteration to perform on a single column.-newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) = UnsafeAlterColumn {renderAlterColumn :: ByteString} deriving (GHC.Generic,Show,Eq,Ord,NFData) @@ -716,15 +796,15 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]] -- definition = alterTable #tab (alterColumn #col (setDefault 5)) -- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5; setDefault- :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set- -> AlterColumn schema (constraint :=> ty) ('Def :=> ty)+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty) setDefault expression = UnsafeAlterColumn $ "SET DEFAULT" <+> renderExpression expression @@ -733,13 +813,13 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] -- definition = alterTable #tab (alterColumn #col dropDefault) -- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;-dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty)+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty) dropDefault = UnsafeAlterColumn $ "DROP DEFAULT" -- | A `setNotNull` adds a @NOT NULL@ constraint to a column.@@ -749,14 +829,14 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]] -- definition = alterTable #tab (alterColumn #col setNotNull) -- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL; setNotNull- :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty) setNotNull = UnsafeAlterColumn $ "SET NOT NULL" -- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.@@ -764,14 +844,14 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]] -- definition = alterTable #tab (alterColumn #col dropNotNull) -- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL; dropNotNull- :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty) dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL" -- | An `alterType` converts a column to a different data type.@@ -781,37 +861,37 @@ -- >>> :{ -- let -- definition :: Definition--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]--- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]] -- definition = -- alterTable #tab (alterColumn #col (alterType (numeric & notNullable))) -- in printSQL definition -- :} -- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;-alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty --- | Create a view.------ >>> :{--- let--- definition :: Definition--- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]--- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])--- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]--- definition =--- createView #bc (select (#b :* #c) (from (table #abc)))--- in printSQL definition--- :}--- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";+{- | Create a view.+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]+>>> :{+let+ definition :: Definition+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]+ definition =+ createView #bc (select_ (#b :* #c) (from (table #abc)))+in printSQL definition+:}+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";+-} createView- :: KnownSymbol view- => Alias view -- ^ the name of the view to add- -> Query schema '[] row- -- ^ query- -> Definition schema (Create view ('View row) schema)+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)+ => QualifiedAlias sch vw -- ^ the name of the view to add+ -> Query '[] '[] schemas '[] view -- ^ query+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas) createView alias query = UnsafeDefinition $- "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS" <+> renderQuery query <> ";" -- | Drop a view.@@ -819,50 +899,56 @@ -- >>> :{ -- let -- definition :: Definition--- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])--- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]--- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]] -- definition = dropView #bc -- in printSQL definition -- :} -- DROP VIEW "bc"; dropView- :: Has view schema ('View v)- => Alias view -- ^ view to remove- -> Definition schema (Drop view schema)-dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"+ :: (Has sch schemas schema, Has vw schema ('View view))+ => QualifiedAlias sch vw -- ^ view to remove+ -> Definition schemas (Alter sch (Drop vw schema) schemas)+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";" -- | Enumerated types are created using the `createTypeEnum` command, for example ----- >>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy")+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]]) -- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy'); createTypeEnum- :: (KnownSymbol enum, SOP.All KnownSymbol labels)- => Alias enum+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)+ => QualifiedAlias sch enum -- ^ name of the user defined enumerated type -> NP PGlabel labels -- ^ labels of the enumerated type- -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas) createTypeEnum enum labels = UnsafeDefinition $- "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+>- parenthesized (commaSeparated (renderLabels labels)) <> ";"+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>+ parenthesized (renderSQL labels) <> ";" -- | Enumerated types can also be generated from a Haskell type, for example -- -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma--- >>> printSQL $ createTypeEnumFrom @Schwarma #schwarma+-- >>> :{+-- let+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma+-- in+-- printSQL createSchwarma+-- :} -- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken'); createTypeEnumFrom- :: forall hask enum schema.+ :: forall hask sch enum schemas schema. ( SOP.Generic hask , SOP.All KnownSymbol (LabelsPG hask) , KnownSymbol enum- )- => Alias enum+ , Has sch schemas schema )+ => QualifiedAlias sch enum -- ^ name of the user defined enumerated type- -> Definition schema (Create enum ('Typedef (PG (Enumerated hask))) schema)+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas) createTypeEnumFrom enum = createTypeEnum enum (SOP.hpure label :: NP PGlabel (LabelsPG hask)) @@ -877,7 +963,7 @@ >>> :{ let- setup :: Definition '[] '["complex" ::: 'Typedef PGcomplex]+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]] setup = createTypeComposite #complex (float8 `as` #real :* float8 `as` #imaginary) in printSQL setup@@ -885,42 +971,80 @@ CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); -} createTypeComposite- :: (KnownSymbol ty, SOP.SListI fields)- => Alias ty+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)+ => QualifiedAlias sch ty -- ^ name of the user defined composite type- -> NP (Aliased (TypeExpression schema)) fields+ -> NP (Aliased (TypeExpression schemas)) fields -- ^ list of attribute names and data types- -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema)+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas) createTypeComposite ty fields = UnsafeDefinition $- "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized (renderCommaSeparated renderField fields) <> ";" where- renderField :: Aliased (TypeExpression schema) x -> ByteString+ renderField :: Aliased (TypeExpression schemas) x -> ByteString renderField (typ `As` alias) =- renderAlias alias <+> renderTypeExpression typ+ renderSQL alias <+> renderSQL typ -- | Composite types can also be generated from a Haskell type, for example -- -- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic -- >>> instance SOP.Generic Complex -- >>> instance SOP.HasDatatypeInfo Complex--- >>> printSQL $ createTypeCompositeFrom @Complex #complex+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]+-- >>> :{+-- let+-- createComplex :: Definition (Public '[]) (Public Schema)+-- createComplex = createTypeCompositeFrom @Complex #complex+-- in+-- printSQL createComplex+-- :} -- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8); createTypeCompositeFrom- :: forall hask ty schema.- ( SOP.All (FieldTyped schema) (RowPG hask)- , KnownSymbol ty )- => Alias ty+ :: forall hask sch ty schemas schema.+ ( SOP.All (FieldTyped schemas) (RowPG hask)+ , KnownSymbol ty+ , Has sch schemas schema )+ => QualifiedAlias sch ty -- ^ name of the user defined composite type- -> Definition schema (Create ty ( 'Typedef (PG (Composite hask))) schema)+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas) createTypeCompositeFrom ty = createTypeComposite ty- (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schema)) fieldtype- :: NP (Aliased (TypeExpression schema)) (RowPG hask))+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask)) -class FieldTyped schema ty where- fieldtype :: Aliased (TypeExpression schema) ty-instance (KnownSymbol alias, PGTyped schema ty)- => FieldTyped schema (alias ::: ty) where+{-|+`createDomain` creates a new domain. A domain is essentially a data type+with constraints (restrictions on the allowed set of values).++Domains are useful for abstracting common constraints on fields+into a single location for maintenance. For example, several tables might+contain email address columns, all requiring the same `check` constraint+to verify the address syntax. Define a domain rather than setting up+each table's constraint individually.++>>> :{+let+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))+in printSQL createPositive+:}+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));+-}+createDomain+ :: (Has sch schemas schema, KnownSymbol dom)+ => QualifiedAlias sch dom+ -> (forall nullity. TypeExpression schemas (nullity ty))+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])+ -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)+createDomain dom ty condition =+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom+ <+> "AS" <+> renderTypeExpression ty+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"++-- | Lift `PGTyped` to a field+class FieldTyped schemas ty where+ fieldtype :: Aliased (TypeExpression schemas) ty+instance (KnownSymbol alias, PGTyped schemas ty)+ => FieldTyped schemas (alias ::: ty) where fieldtype = pgtype `As` Alias -- | Drop a type.@@ -928,57 +1052,59 @@ -- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic -- >>> instance SOP.Generic Schwarma -- >>> instance SOP.HasDatatypeInfo Schwarma--- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))] '[])+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[])) -- DROP TYPE "schwarma"; dropType- :: Has tydef schema ('Typedef ty)- => Alias tydef+ :: (Has sch schemas schema, Has td schema ('Typedef ty))+ => QualifiedAlias sch td -- ^ name of the user defined type- -> Definition schema (Drop tydef schema)-dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"+ -> Definition schemas (Alter sch (Drop td schema) schemas)+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";" -- | `ColumnTypeExpression`s are used in `createTable` commands.-newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType) = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString } deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL (ColumnTypeExpression schemas ty) where+ renderSQL = renderColumnTypeExpression -- | used in `createTable` commands as a column constraint to note that -- @NULL@ may be present in a column nullable- :: TypeExpression schema (nullity ty)- -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)-nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"+ :: TypeExpression schemas (nullity ty)+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL" -- | used in `createTable` commands as a column constraint to ensure -- @NULL@ is not present in a column notNullable- :: TypeExpression schema (nullity ty)- -> ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)-notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"+ :: TypeExpression schemas (nullity ty)+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL" -- | used in `createTable` commands as a column constraint to give a default default_- :: Expression schema '[] 'Ungrouped '[] ty- -> ColumnTypeExpression schema ('NoDef :=> ty)- -> ColumnTypeExpression schema ('Def :=> ty)+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty+ -> ColumnTypeExpression schemas ('NoDef :=> ty)+ -> ColumnTypeExpression schemas ('Def :=> ty) default_ x ty = UnsafeColumnTypeExpression $- renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x+ renderSQL ty <+> "DEFAULT" <+> renderExpression x -- | not a true type, but merely a notational convenience for creating -- unique identifier columns with type `PGint2` serial2, smallserial- :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2) serial2 = UnsafeColumnTypeExpression "serial2" smallserial = UnsafeColumnTypeExpression "smallserial" -- | not a true type, but merely a notational convenience for creating -- unique identifier columns with type `PGint4` serial4, serial- :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4) serial4 = UnsafeColumnTypeExpression "serial4" serial = UnsafeColumnTypeExpression "serial" -- | not a true type, but merely a notational convenience for creating -- unique identifier columns with type `PGint8` serial8, bigserial- :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8) serial8 = UnsafeColumnTypeExpression "serial8" bigserial = UnsafeColumnTypeExpression "bigserial"
src/Squeal/PostgreSQL/Expression.hs view
@@ -1,1758 +1,398 @@ {-|-Module: Squeal.PostgreSQL.Query-Description: Squeal expressions-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--Squeal expressions are the atoms used to build statements.--}--{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-{-# LANGUAGE- AllowAmbiguousTypes- , ConstraintKinds- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GeneralizedNewtypeDeriving- , LambdaCase- , MagicHash- , OverloadedStrings- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , TypeInType- , TypeOperators- , UndecidableInstances- , RankNTypes-#-}--module Squeal.PostgreSQL.Expression- ( -- * Expression- Expression (UnsafeExpression, renderExpression)- , HasParameter (parameter)- , param- -- ** Null- , null_- , notNull- , coalesce- , fromNull- , isNull- , isNotNull- , matchNull- , nullIf- -- ** Collections- , array- , index- , row- , field- -- ** Functions- , unsafeBinaryOp- , unsafeUnaryOp- , unsafeFunction- , unsafeVariadicFunction- , atan2_- , cast- , quot_- , rem_- , trunc- , round_- , ceiling_- , greatest- , least- -- ** Conditions- , true- , false- , not_- , (.&&)- , (.||)- , Condition- , caseWhenThenElse- , ifThenElse- , (.==)- , (./=)- , (.>=)- , (.<)- , (.<=)- , (.>)- -- ** Time- , currentDate- , currentTime- , currentTimestamp- , localTime- , localTimestamp- -- ** Text- , lower- , upper- , charLength- , like- -- ** Json- -- *** Json and Jsonb operators- , (.->)- , (.->>)- , (.#>)- , (.#>>)- -- *** Jsonb operators- , (.@>)- , (.<@)- , (.?)- , (.?|)- , (.?&)- , (.-.)- , (#-.)- -- *** Functions- , jsonLit- , jsonbLit- , toJson- , toJsonb- , arrayToJson- , rowToJson- , jsonBuildArray- , jsonbBuildArray- , jsonBuildObject- , jsonbBuildObject- , jsonObject- , jsonbObject- , jsonZipObject- , jsonbZipObject- , jsonArrayLength- , jsonbArrayLength- , jsonExtractPath- , jsonbExtractPath- , jsonExtractPathAsText- , jsonbExtractPathAsText- , jsonTypeof- , jsonbTypeof- , jsonStripNulls- , jsonbStripNulls- , jsonbSet- , jsonbInsert- , jsonbPretty- -- ** Aggregation- , unsafeAggregate, unsafeAggregateDistinct- , sum_, sumDistinct- , PGAvg (avg, avgDistinct)- , bitAnd, bitOr, boolAnd, boolOr- , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct- , countStar- , count, countDistinct- , every, everyDistinct- , max_, maxDistinct, min_, minDistinct- -- * Types- , TypeExpression (UnsafeTypeExpression, renderTypeExpression)- , PGTyped (pgtype)- , typedef- , typetable- , typeview- , bool- , int2- , smallint- , int4- , int- , integer- , int8- , bigint- , numeric- , float4- , real- , float8- , doublePrecision- , text- , char- , character- , varchar- , characterVarying- , bytea- , timestamp- , timestampWithTimeZone- , date- , time- , timeWithTimeZone- , interval- , uuid- , inet- , json- , jsonb- , vararray- , fixarray- -- * Re-export- , (&)- , NP ((:*), Nil)- ) where--import Control.Category-import Control.DeepSeq-import Data.ByteString (ByteString)-import Data.ByteString.Lazy (toStrict)-import Data.Function ((&))-import Data.Semigroup hiding (All)-import qualified Data.Aeson as JSON-import Data.Ratio-import Data.String-import Data.Word-import Generics.SOP hiding (from)-import GHC.OverloadedLabels-import GHC.TypeLits-import Prelude hiding (id, (.))--import qualified GHC.Generics as GHC--import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema--{------------------------------------------column expressions------------------------------------------}--{- | `Expression`s are used in a variety of contexts,-such as in the target list of the `Squeal.PostgreSQL.Query.select` command,-as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or-`Squeal.PostgreSQL.Manipulation.update`,-or in search `Condition`s in a number of commands.--The expression syntax allows the calculation of-values from primitive expression using arithmetic, logical,-and other operations.--}-newtype Expression- (schema :: SchemaType)- (from :: FromType)- (grouping :: Grouping)- (params :: [NullityType])- (ty :: NullityType)- = UnsafeExpression { renderExpression :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)--instance RenderSQL (Expression schema from grouping params ty) where- renderSQL = renderExpression--{- | A `HasParameter` constraint is used to indicate a value that is-supplied externally to a SQL statement.-`Squeal.PostgreSQL.PQ.manipulateParams`,-`Squeal.PostgreSQL.PQ.queryParams` and-`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values-separately from the SQL command string, in which case `param`s are used to-refer to the out-of-line data values.--}-class KnownNat n => HasParameter- (n :: Nat)- (schema :: SchemaType)- (params :: [NullityType])- (ty :: NullityType)- | n params -> ty where- -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.- --- -- >>> let expr = parameter @1 int4 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)- -- >>> printSQL expr- -- ($1 :: int4)- parameter- :: TypeExpression schema ty- -> Expression schema from grouping params ty- parameter ty = UnsafeExpression $ parenthesized $- "$" <> renderNat @n <+> "::"- <+> renderTypeExpression ty-instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1-instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)- => HasParameter n schema (ty' : params) ty---- | `param` takes a `Nat` using type application and for basic types,--- infers a `TypeExpression`.------ >>> let expr = param @1 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)--- >>> printSQL expr--- ($1 :: int4)-param- :: forall n schema params from grouping ty- . (PGTyped schema ty, HasParameter n schema params ty)- => Expression schema from grouping params ty -- ^ param-param = parameter @n pgtype--instance (HasUnique table from columns, Has column columns ty)- => IsLabel column (Expression schema from 'Ungrouped params ty) where- fromLabel = UnsafeExpression $ renderAlias (Alias @column)-instance (HasUnique table from columns, Has column columns ty)- => IsLabel column- (Aliased (Expression schema from 'Ungrouped params) (column ::: ty)) where- fromLabel = fromLabel @column `As` Alias @column-instance (HasUnique table from columns, Has column columns ty)- => IsLabel column- (NP (Aliased (Expression schema from 'Ungrouped params)) '[column ::: ty]) where- fromLabel = fromLabel @column :* Nil--instance (Has table from columns, Has column columns ty)- => IsQualified table column (Expression schema from 'Ungrouped params ty) where- table ! column = UnsafeExpression $- renderAlias table <> "." <> renderAlias column-instance (Has table from columns, Has column columns ty)- => IsQualified table column- (Aliased (Expression schema from 'Ungrouped params) (column ::: ty)) where- table ! column = table ! column `As` column-instance (Has table from columns, Has column columns ty)- => IsQualified table column- (NP (Aliased (Expression schema from 'Ungrouped params)) '[column ::: ty]) where- table ! column = table ! column :* Nil--instance- ( HasUnique table from columns- , Has column columns ty- , GroupedBy table column bys- ) => IsLabel column- (Expression schema from ('Grouped bys) params ty) where- fromLabel = UnsafeExpression $ renderAlias (Alias @column)-instance- ( HasUnique table from columns- , Has column columns ty- , GroupedBy table column bys- ) => IsLabel column- ( Aliased (Expression schema from ('Grouped bys) params)- (column ::: ty) ) where- fromLabel = fromLabel @column `As` Alias @column-instance- ( HasUnique table from columns- , Has column columns ty- , GroupedBy table column bys- ) => IsLabel column- ( NP (Aliased (Expression schema from ('Grouped bys) params))- '[column ::: ty] ) where- fromLabel = fromLabel @column :* Nil--instance- ( Has table from columns- , Has column columns ty- , GroupedBy table column bys- ) => IsQualified table column- (Expression schema from ('Grouped bys) params ty) where- table ! column = UnsafeExpression $- renderAlias table <> "." <> renderAlias column-instance- ( Has table from columns- , Has column columns ty- , GroupedBy table column bys- ) => IsQualified table column- (Aliased (Expression schema from ('Grouped bys) params)- (column ::: ty)) where- table ! column = table ! column `As` column-instance- ( Has table from columns- , Has column columns ty- , GroupedBy table column bys- ) => IsQualified table column- ( NP (Aliased (Expression schema from ('Grouped bys) params))- '[column ::: ty]) where- table ! column = table ! column :* Nil---- | analagous to `Nothing`------ >>> printSQL null_--- NULL-null_ :: Expression schema rels grouping params ('Null ty)-null_ = UnsafeExpression "NULL"---- | analagous to `Just`------ >>> printSQL $ notNull true--- TRUE-notNull- :: Expression schema rels grouping params ('NotNull ty)- -> Expression schema rels grouping params ('Null ty)-notNull = UnsafeExpression . renderExpression---- | return the leftmost value which is not NULL------ >>> printSQL $ coalesce [null_, true] false--- COALESCE(NULL, TRUE, FALSE)-coalesce- :: [Expression schema from grouping params ('Null ty)]- -- ^ @NULL@s may be present- -> Expression schema from grouping params ('NotNull ty)- -- ^ @NULL@ is absent- -> Expression schema from grouping params ('NotNull ty)-coalesce nullxs notNullx = UnsafeExpression $- "COALESCE" <> parenthesized (commaSeparated- ((renderExpression <$> nullxs) <> [renderExpression notNullx]))---- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@------ >>> printSQL $ fromNull true null_--- COALESCE(NULL, TRUE)-fromNull- :: Expression schema from grouping params ('NotNull ty)- -- ^ what to convert @NULL@ to- -> Expression schema from grouping params ('Null ty)- -> Expression schema from grouping params ('NotNull ty)-fromNull notNullx nullx = coalesce [nullx] notNullx---- | >>> printSQL $ null_ & isNull--- NULL IS NULL-isNull- :: Expression schema from grouping params ('Null ty)- -- ^ possibly @NULL@- -> Condition schema from grouping params-isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"---- | >>> printSQL $ null_ & isNotNull--- NULL IS NOT NULL-isNotNull- :: Expression schema from grouping params ('Null ty)- -- ^ possibly @NULL@- -> Condition schema from grouping params-isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"---- | analagous to `maybe` using @IS NULL@------ >>> printSQL $ matchNull true not_ null_--- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END-matchNull- :: Expression schema from grouping params (nullty)- -- ^ what to convert @NULL@ to- -> ( Expression schema from grouping params ('NotNull ty)- -> Expression schema from grouping params (nullty) )- -- ^ function to perform when @NULL@ is absent- -> Expression schema from grouping params ('Null ty)- -> Expression schema from grouping params (nullty)-matchNull y f x = ifThenElse (isNull x) y- (f (UnsafeExpression (renderExpression x)))--{-| right inverse to `fromNull`, if its arguments are equal then-`nullIf` gives @NULL@.-->>> :set -XTypeApplications -XDataKinds->>> let expr = nullIf false (param @1) :: Expression schema rels grp '[ 'NotNull 'PGbool] ('Null 'PGbool)->>> printSQL expr-NULL IF (FALSE, ($1 :: bool))--}-nullIf- :: Expression schema from grouping params ('NotNull ty)- -- ^ @NULL@ is absent- -> Expression schema from grouping params ('NotNull ty)- -- ^ @NULL@ is absent- -> Expression schema from grouping params ('Null ty)-nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized- (renderExpression x <> ", " <> renderExpression y)---- | >>> printSQL $ array [null_, false, true]--- ARRAY[NULL, FALSE, TRUE]-array- :: [Expression schema from grouping params ty]- -- ^ array elements- -> Expression schema from grouping params (nullity ('PGvararray ty))-array xs = UnsafeExpression $- "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"---- | >>> printSQL $ array [null_, false, true] & index 2--- (ARRAY[NULL, FALSE, TRUE])[2]-index- :: Word64 -- ^ index- -> Expression schema from grouping params (nullity ('PGvararray ty)) -- ^ array- -> Expression schema from grouping params (NullifyType ty)-index n expr = UnsafeExpression $- parenthesized (renderExpression expr) <> "[" <> fromString (show n) <> "]"--instance (KnownSymbol label, label `In` labels) => IsPGlabel label- (Expression schema from grouping params (nullity ('PGenum labels))) where- label = UnsafeExpression $ renderLabel (PGlabel @label)---- | A row constructor is an expression that builds a row value--- (also called a composite value) using values for its member fields.------ >>> :{--- type Complex = 'PGcomposite--- '[ "real" ::: 'NotNull 'PGfloat8--- , "imaginary" ::: 'NotNull 'PGfloat8 ]--- :}------ >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex)--- >>> printSQL i--- ROW(0, 1)-row- :: SListI row- => NP (Aliased (Expression schema from grouping params)) row- -- ^ zero or more expressions for the row field values- -> Expression schema from grouping params (nullity ('PGcomposite row))-row exprs = UnsafeExpression $ "ROW" <> parenthesized- (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)---- | >>> :{--- type Complex = 'PGcomposite--- '[ "real" ::: 'NotNull 'PGfloat8--- , "imaginary" ::: 'NotNull 'PGfloat8 ]--- :}------ >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression '["complex" ::: 'Typedef Complex] '[] 'Ungrouped '[] ('NotNull Complex)--- >>> printSQL $ i & field #complex #imaginary--- (ROW(0, 1)::"complex")."imaginary"-field- :: (Has tydef schema ('Typedef ('PGcomposite row)), Has field row ty)- => Alias tydef -- ^ row type- -> Alias field -- ^ field name- -> Expression schema from grouping params ('NotNull ('PGcomposite row))- -> Expression schema from grouping params ty-field td fld expr = UnsafeExpression $- parenthesized (renderExpression expr <> "::" <> renderAlias td)- <> "." <> renderAlias fld--instance Semigroup- (Expression schema from grouping params (nullity ('PGvararray ty))) where- (<>) = unsafeBinaryOp "||"--instance Monoid- (Expression schema from grouping params (nullity ('PGvararray ty))) where- mempty = array []- mappend = (<>)---- | >>> let expr = greatest currentTimestamp [param @1] :: Expression sch rels grp '[ 'NotNull 'PGtimestamptz] ('NotNull 'PGtimestamptz)--- >>> printSQL expr--- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))-greatest- :: Expression schema from grouping params (nullty)- -- ^ needs at least 1 argument- -> [Expression schema from grouping params (nullty)]- -- ^ or more- -> Expression schema from grouping params (nullty)-greatest x xs = UnsafeExpression $ "GREATEST("- <> commaSeparated (renderExpression <$> (x:xs)) <> ")"---- | >>> printSQL $ least currentTimestamp [null_]--- LEAST(CURRENT_TIMESTAMP, NULL)-least- :: Expression schema from grouping params (nullty)- -- ^ needs at least 1 argument- -> [Expression schema from grouping params (nullty)]- -- ^ or more- -> Expression schema from grouping params (nullty)-least x xs = UnsafeExpression $ "LEAST("- <> commaSeparated (renderExpression <$> (x:xs)) <> ")"---- | >>> printSQL $ unsafeBinaryOp "OR" true false--- (TRUE OR FALSE)-unsafeBinaryOp- :: ByteString- -- ^ operator- -> Expression schema from grouping params (ty0)- -> Expression schema from grouping params (ty1)- -> Expression schema from grouping params (ty2)-unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $- renderExpression x <+> op <+> renderExpression y---- | >>> printSQL $ unsafeUnaryOp "NOT" true--- (NOT TRUE)-unsafeUnaryOp- :: ByteString- -- ^ operator- -> Expression schema from grouping params (ty0)- -> Expression schema from grouping params (ty1)-unsafeUnaryOp op x = UnsafeExpression $ parenthesized $- op <+> renderExpression x---- | >>> printSQL $ unsafeFunction "f" true--- f(TRUE)-unsafeFunction- :: ByteString- -- ^ function- -> Expression schema from grouping params (xty)- -> Expression schema from grouping params (yty)-unsafeFunction fun x = UnsafeExpression $- fun <> parenthesized (renderExpression x)---- | Helper for defining variadic functions.-unsafeVariadicFunction- :: SListI elems- => ByteString- -- ^ function- -> NP (Expression schema from grouping params) elems- -> Expression schema from grouping params ret-unsafeVariadicFunction fun x = UnsafeExpression $- fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderExpression) x)))--instance ty `In` PGNum- => Num (Expression schema from grouping params (nullity ty)) where- (+) = unsafeBinaryOp "+"- (-) = unsafeBinaryOp "-"- (*) = unsafeBinaryOp "*"- abs = unsafeFunction "abs"- signum = unsafeFunction "sign"- fromInteger- = UnsafeExpression- . fromString- . show--instance (ty `In` PGNum, ty `In` PGFloating) => Fractional- (Expression schema from grouping params (nullity ty)) where- (/) = unsafeBinaryOp "/"- fromRational x = fromInteger (numerator x) / fromInteger (denominator x)--instance (ty `In` PGNum, ty `In` PGFloating) => Floating- (Expression schema from grouping params (nullity ty)) where- pi = UnsafeExpression "pi()"- exp = unsafeFunction "exp"- log = unsafeFunction "ln"- sqrt = unsafeFunction "sqrt"- b ** x = UnsafeExpression $- "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"- logBase b y = log y / log b- sin = unsafeFunction "sin"- cos = unsafeFunction "cos"- tan = unsafeFunction "tan"- asin = unsafeFunction "asin"- acos = unsafeFunction "acos"- atan = unsafeFunction "atan"- sinh x = (exp x - exp (-x)) / 2- cosh x = (exp x + exp (-x)) / 2- tanh x = sinh x / cosh x- asinh x = log (x + sqrt (x*x + 1))- acosh x = log (x + sqrt (x*x - 1))- atanh x = log ((1 + x) / (1 - x)) / 2---- | >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGfloat4)--- expression = atan2_ pi 2--- in printSQL expression--- :}--- atan2(pi(), 2)-atan2_- :: float `In` PGFloating- => Expression schema from grouping params (nullity float)- -- ^ numerator- -> Expression schema from grouping params (nullity float)- -- ^ denominator- -> Expression schema from grouping params (nullity float)-atan2_ y x = UnsafeExpression $- "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"---- When a `cast` is applied to an `Expression` of a known type, it--- represents a run-time type conversion. The cast will succeed only if a--- suitable type conversion operation has been defined.------ | >>> printSQL $ true & cast int4--- (TRUE :: int4)-cast- :: TypeExpression schema ty1- -- ^ type to cast as- -> Expression schema from grouping params ty0- -- ^ value to convert- -> Expression schema from grouping params ty1-cast ty x = UnsafeExpression $ parenthesized $- renderExpression x <+> "::" <+> renderTypeExpression ty---- | integer division, truncates the result------ >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGint2)--- expression = 5 `quot_` 2--- in printSQL expression--- :}--- (5 / 2)-quot_- :: int `In` PGIntegral- => Expression schema from grouping params (nullity int)- -- ^ numerator- -> Expression schema from grouping params (nullity int)- -- ^ denominator- -> Expression schema from grouping params (nullity int)-quot_ = unsafeBinaryOp "/"---- | remainder upon integer division------ >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGint2)--- expression = 5 `rem_` 2--- in printSQL expression--- :}--- (5 % 2)-rem_- :: int `In` PGIntegral- => Expression schema from grouping params (nullity int)- -- ^ numerator- -> Expression schema from grouping params (nullity int)- -- ^ denominator- -> Expression schema from grouping params (nullity int)-rem_ = unsafeBinaryOp "%"---- | >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGfloat4)--- expression = trunc pi--- in printSQL expression--- :}--- trunc(pi())-trunc- :: frac `In` PGFloating- => Expression schema from grouping params (nullity frac)- -- ^ fractional number- -> Expression schema from grouping params (nullity frac)-trunc = unsafeFunction "trunc"---- | >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGfloat4)--- expression = round_ pi--- in printSQL expression--- :}--- round(pi())-round_- :: frac `In` PGFloating- => Expression schema from grouping params (nullity frac)- -- ^ fractional number- -> Expression schema from grouping params (nullity frac)-round_ = unsafeFunction "round"---- | >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGfloat4)--- expression = ceiling_ pi--- in printSQL expression--- :}--- ceiling(pi())-ceiling_- :: frac `In` PGFloating- => Expression schema from grouping params (nullity frac)- -- ^ fractional number- -> Expression schema from grouping params (nullity frac)-ceiling_ = unsafeFunction "ceiling"---- | A `Condition` is an `Expression`, which can evaluate--- to `true`, `false` or `null_`. This is because SQL uses--- a three valued logic.-type Condition schema from grouping params =- Expression schema from grouping params ('Null 'PGbool)---- | >>> printSQL true--- TRUE-true :: Expression schema from grouping params (nullity 'PGbool)-true = UnsafeExpression "TRUE"---- | >>> printSQL false--- FALSE-false :: Expression schema from grouping params (nullity 'PGbool)-false = UnsafeExpression "FALSE"---- | >>> printSQL $ not_ true--- (NOT TRUE)-not_- :: Expression schema from grouping params (nullity 'PGbool)- -> Expression schema from grouping params (nullity 'PGbool)-not_ = unsafeUnaryOp "NOT"---- | >>> printSQL $ true .&& false--- (TRUE AND FALSE)-(.&&)- :: Expression schema from grouping params (nullity 'PGbool)- -> Expression schema from grouping params (nullity 'PGbool)- -> Expression schema from grouping params (nullity 'PGbool)-infixr 3 .&&-(.&&) = unsafeBinaryOp "AND"---- | >>> printSQL $ true .|| false--- (TRUE OR FALSE)-(.||)- :: Expression schema from grouping params (nullity 'PGbool)- -> Expression schema from grouping params (nullity 'PGbool)- -> Expression schema from grouping params (nullity 'PGbool)-infixr 2 .||-(.||) = unsafeBinaryOp "OR"---- | >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGint2)--- expression = caseWhenThenElse [(true, 1), (false, 2)] 3--- in printSQL expression--- :}--- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END-caseWhenThenElse- :: [ ( Condition schema from grouping params- , Expression schema from grouping params ty- ) ]- -- ^ whens and thens- -> Expression schema from grouping params ty- -- ^ else- -> Expression schema from grouping params ty-caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat- [ "CASE"- , mconcat- [ mconcat- [ " WHEN ", renderExpression when_- , " THEN ", renderExpression then_- ]- | (when_,then_) <- whenThens- ]- , " ELSE ", renderExpression else_- , " END"- ]---- | >>> :{--- let--- expression :: Expression schema from grouping params (nullity 'PGint2)--- expression = ifThenElse true 1 0--- in printSQL expression--- :}--- CASE WHEN TRUE THEN 1 ELSE 0 END-ifThenElse- :: Condition schema from grouping params- -> Expression schema from grouping params ty -- ^ then- -> Expression schema from grouping params ty -- ^ else- -> Expression schema from grouping params ty-ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_---- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`--- will produce @NULL@s if one of their arguments is @NULL@.------ >>> printSQL $ true .== null_--- (TRUE = NULL)-(.==)- :: Expression schema from grouping params (nullity0 ty) -- ^ lhs- -> Expression schema from grouping params (nullity1 ty) -- ^ rhs- -> Condition schema from grouping params-(.==) = unsafeBinaryOp "="-infix 4 .==---- | >>> printSQL $ true ./= null_--- (TRUE <> NULL)-(./=)- :: Expression schema from grouping params (nullity0 ty) -- ^ lhs- -> Expression schema from grouping params (nullity1 ty) -- ^ rhs- -> Condition schema from grouping params-(./=) = unsafeBinaryOp "<>"-infix 4 ./=---- | >>> printSQL $ true .>= null_--- (TRUE >= NULL)-(.>=)- :: Expression schema from grouping params (nullity0 ty) -- ^ lhs- -> Expression schema from grouping params (nullity1 ty) -- ^ rhs- -> Condition schema from grouping params-(.>=) = unsafeBinaryOp ">="-infix 4 .>=---- | >>> printSQL $ true .< null_--- (TRUE < NULL)-(.<)- :: Expression schema from grouping params (nullity0 ty) -- ^ lhs- -> Expression schema from grouping params (nullity1 ty) -- ^ rhs- -> Condition schema from grouping params-(.<) = unsafeBinaryOp "<"-infix 4 .<---- | >>> printSQL $ true .<= null_--- (TRUE <= NULL)-(.<=)- :: Expression schema from grouping params (nullity0 ty) -- ^ lhs- -> Expression schema from grouping params (nullity1 ty) -- ^ rhs- -> Condition schema from grouping params-(.<=) = unsafeBinaryOp "<="-infix 4 .<=---- | >>> printSQL $ true .> null_--- (TRUE > NULL)-(.>)- :: Expression schema from grouping params (nullity0 ty) -- ^ lhs- -> Expression schema from grouping params (nullity1 ty) -- ^ rhs- -> Condition schema from grouping params-(.>) = unsafeBinaryOp ">"-infix 4 .>---- | >>> printSQL currentDate--- CURRENT_DATE-currentDate- :: Expression schema from grouping params (nullity 'PGdate)-currentDate = UnsafeExpression "CURRENT_DATE"---- | >>> printSQL currentTime--- CURRENT_TIME-currentTime- :: Expression schema from grouping params (nullity 'PGtimetz)-currentTime = UnsafeExpression "CURRENT_TIME"---- | >>> printSQL currentTimestamp--- CURRENT_TIMESTAMP-currentTimestamp- :: Expression schema from grouping params (nullity 'PGtimestamptz)-currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"---- | >>> printSQL localTime--- LOCALTIME-localTime- :: Expression schema from grouping params (nullity 'PGtime)-localTime = UnsafeExpression "LOCALTIME"---- | >>> printSQL localTimestamp--- LOCALTIMESTAMP-localTimestamp- :: Expression schema from grouping params (nullity 'PGtimestamp)-localTimestamp = UnsafeExpression "LOCALTIMESTAMP"--{------------------------------------------text------------------------------------------}--instance IsString- (Expression schema from grouping params (nullity 'PGtext)) where- fromString str = UnsafeExpression $- "E\'" <> fromString (escape =<< str) <> "\'"- where- escape = \case- '\NUL' -> "\\0"- '\'' -> "''"- '"' -> "\\\""- '\b' -> "\\b"- '\n' -> "\\n"- '\r' -> "\\r"- '\t' -> "\\t"- '\\' -> "\\\\"- c -> [c]--instance Semigroup- (Expression schema from grouping params (nullity 'PGtext)) where- (<>) = unsafeBinaryOp "||"--instance Monoid- (Expression schema from grouping params (nullity 'PGtext)) where- mempty = fromString ""- mappend = (<>)---- | >>> printSQL $ lower "ARRRGGG"--- lower(E'ARRRGGG')-lower- :: Expression schema from grouping params (nullity 'PGtext)- -- ^ string to lower case- -> Expression schema from grouping params (nullity 'PGtext)-lower = unsafeFunction "lower"---- | >>> printSQL $ upper "eeee"--- upper(E'eeee')-upper- :: Expression schema from grouping params (nullity 'PGtext)- -- ^ string to upper case- -> Expression schema from grouping params (nullity 'PGtext)-upper = unsafeFunction "upper"---- | >>> printSQL $ charLength "four"--- char_length(E'four')-charLength- :: Expression schema from grouping params (nullity 'PGtext)- -- ^ string to measure- -> Expression schema from grouping params (nullity 'PGint4)-charLength = unsafeFunction "char_length"---- | The `like` expression returns true if the @string@ matches--- the supplied @pattern@. If @pattern@ does not contain percent signs--- or underscores, then the pattern only represents the string itself;--- in that case `like` acts like the equals operator. An underscore (_)--- in pattern stands for (matches) any single character; a percent sign (%)--- matches any sequence of zero or more characters.------ >>> printSQL $ "abc" `like` "a%"--- (E'abc' LIKE E'a%')-like- :: Expression schema from grouping params (nullity 'PGtext)- -- ^ string- -> Expression schema from grouping params (nullity 'PGtext)- -- ^ pattern- -> Expression schema from grouping params (nullity 'PGbool)-like = unsafeBinaryOp "LIKE"--{------------------------------------------ -- json and jsonb support--See https://www.postgresql.org/docs/10/static/functions-json.html -- most-comments lifted directly from this page.--Table 9.44: json and jsonb operators------------------------------------------}---- | Get JSON value (object field or array element) at a key.-(.->)- :: (json `In` PGJsonType, key `In` PGJsonKey)- => Expression schema from grouping params (nullity json)- -> Expression schema from grouping params (nullity key)- -> Expression schema from grouping params ('Null json)-infixl 8 .->-(.->) = unsafeBinaryOp "->"---- | Get JSON value (object field or array element) at a key, as text.-(.->>)- :: (json `In` PGJsonType, key `In` PGJsonKey)- => Expression schema from grouping params (nullity json)- -> Expression schema from grouping params (nullity key)- -> Expression schema from grouping params ('Null 'PGtext)-infixl 8 .->>-(.->>) = unsafeBinaryOp "->>"---- | Get JSON value at a specified path.-(.#>)- :: (json `In` PGJsonType, PGTextArray "(.#>)" path)- => Expression schema from grouping params (nullity json)- -> Expression schema from grouping params (nullity path)- -> Expression schema from grouping params ('Null json)-infixl 8 .#>-(.#>) = unsafeBinaryOp "#>"---- | Get JSON value at a specified path as text.-(.#>>)- :: (json `In` PGJsonType, PGTextArray "(.#>>)" path)- => Expression schema from grouping params (nullity json)- -> Expression schema from grouping params (nullity path)- -> Expression schema from grouping params ('Null 'PGtext)-infixl 8 .#>>-(.#>>) = unsafeBinaryOp "#>>"---- Additional jsonb operators---- | Does the left JSON value contain the right JSON path/value entries at the--- top level?-(.@>)- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGjsonb)- -> Condition schema from grouping params-infixl 9 .@>-(.@>) = unsafeBinaryOp "@>"---- | Are the left JSON path/value entries contained at the top level within the--- right JSON value?-(.<@)- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGjsonb)- -> Condition schema from grouping params-infixl 9 .<@-(.<@) = unsafeBinaryOp "<@"---- | Does the string exist as a top-level key within the JSON value?-(.?)- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGtext)- -> Condition schema from grouping params-infixl 9 .?-(.?) = unsafeBinaryOp "?"---- | Do any of these array strings exist as top-level keys?-(.?|)- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity ('PGvararray ('NotNull 'PGtext)))- -> Condition schema from grouping params-infixl 9 .?|-(.?|) = unsafeBinaryOp "?|"---- | Do all of these array strings exist as top-level keys?-(.?&)- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity ('PGvararray ('NotNull 'PGtext)))- -> Condition schema from grouping params-infixl 9 .?&-(.?&) = unsafeBinaryOp "?&"---- | Concatenate two jsonb values into a new jsonb value.-instance- Semigroup (Expression schema from grouping param (nullity 'PGjsonb)) where- (<>) = unsafeBinaryOp "||"---- | Delete a key or keys from a JSON object, or remove an array element.------ If the right operand is..------ @ text @: Delete key/value pair or string element from left operand. Key/value pairs--- are matched based on their key value.------ @ text[] @: Delete multiple key/value pairs or string elements--- from left operand. Key/value pairs are matched based on their key value.------ @ integer @: Delete the array element with specified index (Negative integers--- count from the end). Throws an error if top level container is not an array.-(.-.)- :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here- => Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity key)- -> Expression schema from grouping params (nullity 'PGjsonb)-infixl 6 .-.-(.-.) = unsafeBinaryOp "-"---- | Delete the field or element with specified path (for JSON arrays, negative--- integers count from the end)-(#-.)- :: PGTextArray "(#-.)" arrayty- => Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity arrayty)- -> Expression schema from grouping params (nullity 'PGjsonb)-infixl 6 #-.-(#-.) = unsafeBinaryOp "#-"--{------------------------------------------Table 9.45: JSON creation functions------------------------------------------}---- | Literal binary JSON-jsonbLit- :: JSON.ToJSON x- => x -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbLit = cast jsonb . UnsafeExpression- . singleQuotedUtf8 . toStrict . JSON.encode---- | Literal JSON-jsonLit- :: JSON.ToJSON x- => x -> Expression schema from grouping params (nullity 'PGjson)-jsonLit = cast json . UnsafeExpression- . singleQuotedUtf8 . toStrict . JSON.encode---- | Returns the value as json. Arrays and composites are converted--- (recursively) to arrays and objects; otherwise, if there is a cast from the--- type to json, the cast function will be used to perform the conversion;--- otherwise, a scalar value is produced. For any scalar type other than a--- number, a Boolean, or a null value, the text representation will be used, in--- such a fashion that it is a valid json value.-toJson- :: Expression schema from grouping params (nullity ty)- -> Expression schema from grouping params (nullity 'PGjson)-toJson = unsafeFunction "to_json"---- | Returns the value as jsonb. Arrays and composites are converted--- (recursively) to arrays and objects; otherwise, if there is a cast from the--- type to json, the cast function will be used to perform the conversion;--- otherwise, a scalar value is produced. For any scalar type other than a--- number, a Boolean, or a null value, the text representation will be used, in--- such a fashion that it is a valid jsonb value.-toJsonb- :: Expression schema from grouping params (nullity ty)- -> Expression schema from grouping params (nullity 'PGjsonb)-toJsonb = unsafeFunction "to_jsonb"---- | Returns the array as a JSON array. A PostgreSQL multidimensional array--- becomes a JSON array of arrays.-arrayToJson- :: PGArray "arrayToJson" arr- => Expression schema from grouping params (nullity arr)- -> Expression schema from grouping params (nullity 'PGjson)-arrayToJson = unsafeFunction "array_to_json"---- | Returns the row as a JSON object.-rowToJson- :: Expression schema from grouping params (nullity ('PGcomposite ty))- -> Expression schema from grouping params (nullity 'PGjson)-rowToJson = unsafeFunction "row_to_json"---- | Builds a possibly-heterogeneously-typed JSON array out of a variadic--- argument list.-jsonBuildArray- :: SListI elems- => NP (Expression schema from grouping params) elems- -> Expression schema from grouping params (nullity 'PGjson)-jsonBuildArray = unsafeVariadicFunction "json_build_array"---- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a--- variadic argument list.-jsonbBuildArray- :: SListI elems- => NP (Expression schema from grouping params) elems- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbBuildArray = unsafeVariadicFunction "jsonb_build_array"--unsafeRowFunction- :: All Top elems- => NP (Aliased (Expression schema from grouping params)) elems- -> [ByteString]-unsafeRowFunction =- (`appEndo` []) . hcfoldMap (Proxy :: Proxy Top)- (\(col `As` name) -> Endo $ \xs ->- renderAliasString name : renderExpression col : xs)---- | Builds a possibly-heterogeneously-typed JSON object out of a variadic--- argument list. The elements of the argument list must alternate between text--- and values.-jsonBuildObject- :: All Top elems- => NP (Aliased (Expression schema from grouping params)) elems- -> Expression schema from grouping params (nullity 'PGjson)-jsonBuildObject- = unsafeFunction "json_build_object"- . UnsafeExpression- . commaSeparated- . unsafeRowFunction---- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a--- variadic argument list. The elements of the argument list must alternate--- between text and values.-jsonbBuildObject- :: All Top elems- => NP (Aliased (Expression schema from grouping params)) elems- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbBuildObject- = unsafeFunction "jsonb_build_object"- . UnsafeExpression- . commaSeparated- . unsafeRowFunction---- | Builds a JSON object out of a text array. The array must have either--- exactly one dimension with an even number of members, in which case they are--- taken as alternating key/value pairs, or two dimensions such that each inner--- array has exactly two elements, which are taken as a key/value pair.-jsonObject- :: PGArrayOf "jsonObject" arr ('NotNull 'PGtext)- => Expression schema from grouping params (nullity arr)- -> Expression schema from grouping params (nullity 'PGjson)-jsonObject = unsafeFunction "json_object"---- | Builds a binary JSON object out of a text array. The array must have either--- exactly one dimension with an even number of members, in which case they are--- taken as alternating key/value pairs, or two dimensions such that each inner--- array has exactly two elements, which are taken as a key/value pair.-jsonbObject- :: PGArrayOf "jsonbObject" arr ('NotNull 'PGtext)- => Expression schema from grouping params (nullity arr)- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbObject = unsafeFunction "jsonb_object"---- | This is an alternate form of 'jsonObject' that takes two arrays; one for--- keys and one for values, that are zipped pairwise to create a JSON object.-jsonZipObject- :: ( PGArrayOf "jsonZipObject" keysArray ('NotNull 'PGtext)- , PGArrayOf "jsonZipObject" valuesArray ('NotNull 'PGtext))- => Expression schema from grouping params (nullity keysArray)- -> Expression schema from grouping params (nullity valuesArray)- -> Expression schema from grouping params (nullity 'PGjson)-jsonZipObject ks vs =- unsafeVariadicFunction "json_object" (ks :* vs :* Nil)---- | This is an alternate form of 'jsonObject' that takes two arrays; one for--- keys and one for values, that are zipped pairwise to create a binary JSON--- object.-jsonbZipObject- :: ( PGArrayOf "jsonbZipObject" keysArray ('NotNull 'PGtext)- , PGArrayOf "jsonbZipObject" valuesArray ('NotNull 'PGtext))- => Expression schema from grouping params (nullity keysArray)- -> Expression schema from grouping params (nullity valuesArray)- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbZipObject ks vs =- unsafeVariadicFunction "jsonb_object" (ks :* vs :* Nil)--{------------------------------------------Table 9.46: JSON processing functions------------------------------------------}---- | Returns the number of elements in the outermost JSON array.-jsonArrayLength- :: Expression schema from grouping params (nullity 'PGjson)- -> Expression schema from grouping params (nullity 'PGint4)-jsonArrayLength = unsafeFunction "json_array_length"---- | Returns the number of elements in the outermost binary JSON array.-jsonbArrayLength- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGint4)-jsonbArrayLength = unsafeFunction "jsonb_array_length"---- | Returns JSON value pointed to by the given path (equivalent to #>--- operator).-jsonExtractPath- :: SListI elems- => Expression schema from grouping params (nullity 'PGjson)- -> NP (Expression schema from grouping params) elems- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonExtractPath x xs =- unsafeVariadicFunction "json_extract_path" (x :* xs)---- | Returns JSON value pointed to by the given path (equivalent to #>--- operator).-jsonbExtractPath- :: SListI elems- => Expression schema from grouping params (nullity 'PGjsonb)- -> NP (Expression schema from grouping params) elems- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbExtractPath x xs =- unsafeVariadicFunction "jsonb_extract_path" (x :* xs)---- | Returns JSON value pointed to by the given path (equivalent to #>--- operator), as text.-jsonExtractPathAsText- :: SListI elems- => Expression schema from grouping params (nullity 'PGjson)- -> NP (Expression schema from grouping params) elems- -> Expression schema from grouping params (nullity 'PGjson)-jsonExtractPathAsText x xs =- unsafeVariadicFunction "json_extract_path_text" (x :* xs)---- | Returns JSON value pointed to by the given path (equivalent to #>--- operator), as text.-jsonbExtractPathAsText- :: SListI elems- => Expression schema from grouping params (nullity 'PGjsonb)- -> NP (Expression schema from grouping params) elems- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbExtractPathAsText x xs =- unsafeVariadicFunction "jsonb_extract_path_text" (x :* xs)---- | Returns the type of the outermost JSON value as a text string. Possible--- types are object, array, string, number, boolean, and null.-jsonTypeof- :: Expression schema from grouping params (nullity 'PGjson)- -> Expression schema from grouping params (nullity 'PGtext)-jsonTypeof = unsafeFunction "json_typeof"---- | Returns the type of the outermost binary JSON value as a text string.--- Possible types are object, array, string, number, boolean, and null.-jsonbTypeof- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGtext)-jsonbTypeof = unsafeFunction "jsonb_typeof"---- | Returns its argument with all object fields that have null values omitted.--- Other null values are untouched.-jsonStripNulls- :: Expression schema from grouping params (nullity 'PGjson)- -> Expression schema from grouping params (nullity 'PGjson)-jsonStripNulls = unsafeFunction "json_strip_nulls"---- | Returns its argument with all object fields that have null values omitted.--- Other null values are untouched.-jsonbStripNulls- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"---- | @ jsonbSet target path new_value create_missing @------ Returns target with the section designated by path replaced by new_value,--- or with new_value added if create_missing is true ( default is true) and the--- item designated by path does not exist. As with the path orientated--- operators, negative integers that appear in path count from the end of JSON--- arrays.-jsonbSet- :: PGTextArray "jsonbSet" arr- => Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity arr)- -> Expression schema from grouping params (nullity 'PGjsonb)- -> Maybe (Expression schema from grouping params (nullity 'PGbool))- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbSet tgt path val createMissing = case createMissing of- Just m -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* m :* Nil)- Nothing -> unsafeVariadicFunction "jsonb_set" (tgt :* path :* val :* Nil)---- | @ jsonbInsert target path new_value insert_after @------ Returns target with new_value inserted. If target section designated by--- path is in a JSONB array, new_value will be inserted before target or after--- if insert_after is true (default is false). If target section designated by--- path is in JSONB object, new_value will be inserted only if target does not--- exist. As with the path orientated operators, negative integers that appear--- in path count from the end of JSON arrays.-jsonbInsert- :: PGTextArray "jsonbInsert" arr- => Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity arr)- -> Expression schema from grouping params (nullity 'PGjsonb)- -> Maybe (Expression schema from grouping params (nullity 'PGbool))- -> Expression schema from grouping params (nullity 'PGjsonb)-jsonbInsert tgt path val insertAfter = case insertAfter of- Just i -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* i :* Nil)- Nothing -> unsafeVariadicFunction "jsonb_insert" (tgt :* path :* val :* Nil)---- | Returns its argument as indented JSON text.-jsonbPretty- :: Expression schema from grouping params (nullity 'PGjsonb)- -> Expression schema from grouping params (nullity 'PGtext)-jsonbPretty = unsafeFunction "jsonb_pretty"--{------------------------------------------aggregation------------------------------------------}---- | escape hatch to define aggregate functions-unsafeAggregate- :: ByteString -- ^ aggregate function- -> Expression schema from 'Ungrouped params (xty)- -> Expression schema from ('Grouped bys) params (yty)-unsafeAggregate fun x = UnsafeExpression $ mconcat- [fun, "(", renderExpression x, ")"]---- | escape hatch to define aggregate functions over distinct values-unsafeAggregateDistinct- :: ByteString -- ^ aggregate function- -> Expression schema from 'Ungrouped params (xty)- -> Expression schema from ('Grouped bys) params (yty)-unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat- [fun, "(DISTINCT ", renderExpression x, ")"]---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)--- expression = sum_ #col--- in printSQL expression--- :}--- sum("col")-sum_- :: ty `In` PGNum- => Expression schema from 'Ungrouped params (nullity ty)- -- ^ what to sum- -> Expression schema from ('Grouped bys) params (nullity ty)-sum_ = unsafeAggregate "sum"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)--- expression = sumDistinct #col--- in printSQL expression--- :}--- sum(DISTINCT "col")-sumDistinct- :: ty `In` PGNum- => Expression schema from 'Ungrouped params (nullity ty)- -- ^ what to sum- -> Expression schema from ('Grouped bys) params (nullity ty)-sumDistinct = unsafeAggregateDistinct "sum"---- | A constraint for `PGType`s that you can take averages of and the resulting--- `PGType`.-class PGAvg ty avg | ty -> avg where- avg, avgDistinct- :: Expression schema from 'Ungrouped params (nullity ty)- -- ^ what to average- -> Expression schema from ('Grouped bys) params (nullity avg)- avg = unsafeAggregate "avg"- avgDistinct = unsafeAggregateDistinct "avg"-instance PGAvg 'PGint2 'PGnumeric-instance PGAvg 'PGint4 'PGnumeric-instance PGAvg 'PGint8 'PGnumeric-instance PGAvg 'PGnumeric 'PGnumeric-instance PGAvg 'PGfloat4 'PGfloat8-instance PGAvg 'PGfloat8 'PGfloat8-instance PGAvg 'PGinterval 'PGinterval---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)--- expression = bitAnd #col--- in printSQL expression--- :}--- bit_and("col")-bitAnd- :: int `In` PGIntegral- => Expression schema from 'Ungrouped params (nullity int)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity int)-bitAnd = unsafeAggregate "bit_and"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)--- expression = bitOr #col--- in printSQL expression--- :}--- bit_or("col")-bitOr- :: int `In` PGIntegral- => Expression schema from 'Ungrouped params (nullity int)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity int)-bitOr = unsafeAggregate "bit_or"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)--- expression = bitAndDistinct #col--- in printSQL expression--- :}--- bit_and(DISTINCT "col")-bitAndDistinct- :: int `In` PGIntegral- => Expression schema from 'Ungrouped params (nullity int)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity int)-bitAndDistinct = unsafeAggregateDistinct "bit_and"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)--- expression = bitOrDistinct #col--- in printSQL expression--- :}--- bit_or(DISTINCT "col")-bitOrDistinct- :: int `In` PGIntegral- => Expression schema from 'Ungrouped params (nullity int)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity int)-bitOrDistinct = unsafeAggregateDistinct "bit_or"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)--- expression = boolAnd #col--- in printSQL expression--- :}--- bool_and("col")-boolAnd- :: Expression schema from 'Ungrouped params (nullity 'PGbool)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity 'PGbool)-boolAnd = unsafeAggregate "bool_and"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)--- expression = boolOr #col--- in printSQL expression--- :}--- bool_or("col")-boolOr- :: Expression schema from 'Ungrouped params (nullity 'PGbool)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity 'PGbool)-boolOr = unsafeAggregate "bool_or"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)--- expression = boolAndDistinct #col--- in printSQL expression--- :}--- bool_and(DISTINCT "col")-boolAndDistinct- :: Expression schema from 'Ungrouped params (nullity 'PGbool)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity 'PGbool)-boolAndDistinct = unsafeAggregateDistinct "bool_and"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)--- expression = boolOrDistinct #col--- in printSQL expression--- :}--- bool_or(DISTINCT "col")-boolOrDistinct- :: Expression schema from 'Ungrouped params (nullity 'PGbool)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity 'PGbool)-boolOrDistinct = unsafeAggregateDistinct "bool_or"---- | A special aggregation that does not require an input------ >>> printSQL countStar--- count(*)-countStar- :: Expression schema from ('Grouped bys) params ('NotNull 'PGint8)-countStar = UnsafeExpression $ "count(*)"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)--- expression = count #col--- in printSQL expression--- :}--- count("col")-count- :: Expression schema from 'Ungrouped params ty- -- ^ what to count- -> Expression schema from ('Grouped bys) params ('NotNull 'PGint8)-count = unsafeAggregate "count"---- | >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)--- expression = countDistinct #col--- in printSQL expression--- :}--- count(DISTINCT "col")-countDistinct- :: Expression schema from 'Ungrouped params ty- -- ^ what to count- -> Expression schema from ('Grouped bys) params ('NotNull 'PGint8)-countDistinct = unsafeAggregateDistinct "count"---- | synonym for `boolAnd`------ >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)--- expression = every #col--- in printSQL expression--- :}--- every("col")-every- :: Expression schema from 'Ungrouped params (nullity 'PGbool)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity 'PGbool)-every = unsafeAggregate "every"---- | synonym for `boolAndDistinct`------ >>> :{--- let--- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)--- expression = everyDistinct #col--- in printSQL expression--- :}--- every(DISTINCT "col")-everyDistinct- :: Expression schema from 'Ungrouped params (nullity 'PGbool)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity 'PGbool)-everyDistinct = unsafeAggregateDistinct "every"---- | minimum and maximum aggregation-max_, min_, maxDistinct, minDistinct- :: Expression schema from 'Ungrouped params (nullity ty)- -- ^ what to aggregate- -> Expression schema from ('Grouped bys) params (nullity ty)-max_ = unsafeAggregate "max"-min_ = unsafeAggregate "min"-maxDistinct = unsafeAggregateDistinct "max"-minDistinct = unsafeAggregateDistinct "min"--{------------------------------------------type expressions------------------------------------------}---- | `TypeExpression`s are used in `cast`s and `createTable` commands.-newtype TypeExpression (schema :: SchemaType) (ty :: NullityType)- = UnsafeTypeExpression { renderTypeExpression :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)---- | The enum or composite type in a `Typedef` can be expressed by its alias.-typedef- :: Has alias schema ('Typedef ty)- => Alias alias- -> TypeExpression schema (nullity ty)-typedef = UnsafeTypeExpression . renderAlias---- | The composite type corresponding to a `Table` definition can be expressed--- by its alias.-typetable- :: Has alias schema ('Table tab)- => Alias alias- -> TypeExpression schema (nullity ('PGcomposite (TableToRow tab)))-typetable = UnsafeTypeExpression . renderAlias---- | The composite type corresponding to a `View` definition can be expressed--- by its alias.-typeview- :: Has alias schema ('View view)- => Alias alias- -> TypeExpression schema (nullity ('PGcomposite view))-typeview = UnsafeTypeExpression . renderAlias---- | logical Boolean (true/false)-bool :: TypeExpression schema (nullity 'PGbool)-bool = UnsafeTypeExpression "bool"--- | signed two-byte integer-int2, smallint :: TypeExpression schema (nullity 'PGint2)-int2 = UnsafeTypeExpression "int2"-smallint = UnsafeTypeExpression "smallint"--- | signed four-byte integer-int4, int, integer :: TypeExpression schema (nullity 'PGint4)-int4 = UnsafeTypeExpression "int4"-int = UnsafeTypeExpression "int"-integer = UnsafeTypeExpression "integer"--- | signed eight-byte integer-int8, bigint :: TypeExpression schema (nullity 'PGint8)-int8 = UnsafeTypeExpression "int8"-bigint = UnsafeTypeExpression "bigint"--- | arbitrary precision numeric type-numeric :: TypeExpression schema (nullity 'PGnumeric)-numeric = UnsafeTypeExpression "numeric"--- | single precision floating-point number (4 bytes)-float4, real :: TypeExpression schema (nullity 'PGfloat4)-float4 = UnsafeTypeExpression "float4"-real = UnsafeTypeExpression "real"--- | double precision floating-point number (8 bytes)-float8, doublePrecision :: TypeExpression schema (nullity 'PGfloat8)-float8 = UnsafeTypeExpression "float8"-doublePrecision = UnsafeTypeExpression "double precision"--- | variable-length character string-text :: TypeExpression schema (nullity 'PGtext)-text = UnsafeTypeExpression "text"--- | fixed-length character string-char, character- :: forall n schema nullity. (KnownNat n, 1 <= n)- => TypeExpression schema (nullity ('PGchar n))-char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"-character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"--- | variable-length character string-varchar, characterVarying- :: forall n schema nullity. (KnownNat n, 1 <= n)- => TypeExpression schema (nullity ('PGvarchar n))-varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"-characterVarying = UnsafeTypeExpression $- "character varying(" <> renderNat @n <> ")"--- | binary data ("byte array")-bytea :: TypeExpression schema (nullity 'PGbytea)-bytea = UnsafeTypeExpression "bytea"--- | date and time (no time zone)-timestamp :: TypeExpression schema (nullity 'PGtimestamp)-timestamp = UnsafeTypeExpression "timestamp"--- | date and time, including time zone-timestampWithTimeZone :: TypeExpression schema (nullity 'PGtimestamptz)-timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"--- | calendar date (year, month, day)-date :: TypeExpression schema (nullity 'PGdate)-date = UnsafeTypeExpression "date"--- | time of day (no time zone)-time :: TypeExpression schema (nullity 'PGtime)-time = UnsafeTypeExpression "time"--- | time of day, including time zone-timeWithTimeZone :: TypeExpression schema (nullity 'PGtimetz)-timeWithTimeZone = UnsafeTypeExpression "time with time zone"--- | time span-interval :: TypeExpression schema (nullity 'PGinterval)-interval = UnsafeTypeExpression "interval"--- | universally unique identifier-uuid :: TypeExpression schema (nullity 'PGuuid)-uuid = UnsafeTypeExpression "uuid"--- | IPv4 or IPv6 host address-inet :: TypeExpression schema (nullity 'PGinet)-inet = UnsafeTypeExpression "inet"--- | textual JSON data-json :: TypeExpression schema (nullity 'PGjson)-json = UnsafeTypeExpression "json"--- | binary JSON data, decomposed-jsonb :: TypeExpression schema (nullity 'PGjsonb)-jsonb = UnsafeTypeExpression "jsonb"--- | variable length array-vararray- :: TypeExpression schema pg- -> TypeExpression schema (nullity ('PGvararray pg))-vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"--- | fixed length array------ >>> renderTypeExpression (fixarray @2 json)--- "json[2]"-fixarray- :: forall n schema nullity pg. KnownNat n- => TypeExpression schema pg- -> TypeExpression schema (nullity ('PGfixarray n pg))-fixarray ty = UnsafeTypeExpression $- renderTypeExpression ty <> "[" <> renderNat @n <> "]"---- | `pgtype` is a demoted version of a `PGType`-class PGTyped schema (ty :: NullityType) where- pgtype :: TypeExpression schema ty-instance PGTyped schema (nullity 'PGbool) where pgtype = bool-instance PGTyped schema (nullity 'PGint2) where pgtype = int2-instance PGTyped schema (nullity 'PGint4) where pgtype = int4-instance PGTyped schema (nullity 'PGint8) where pgtype = int8-instance PGTyped schema (nullity 'PGnumeric) where pgtype = numeric-instance PGTyped schema (nullity 'PGfloat4) where pgtype = float4-instance PGTyped schema (nullity 'PGfloat8) where pgtype = float8-instance PGTyped schema (nullity 'PGtext) where pgtype = text-instance (KnownNat n, 1 <= n)- => PGTyped schema (nullity ('PGchar n)) where pgtype = char @n-instance (KnownNat n, 1 <= n)- => PGTyped schema (nullity ('PGvarchar n)) where pgtype = varchar @n-instance PGTyped schema (nullity 'PGbytea) where pgtype = bytea-instance PGTyped schema (nullity 'PGtimestamp) where pgtype = timestamp-instance PGTyped schema (nullity 'PGtimestamptz) where pgtype = timestampWithTimeZone-instance PGTyped schema (nullity 'PGdate) where pgtype = date-instance PGTyped schema (nullity 'PGtime) where pgtype = time-instance PGTyped schema (nullity 'PGtimetz) where pgtype = timeWithTimeZone-instance PGTyped schema (nullity 'PGinterval) where pgtype = interval-instance PGTyped schema (nullity 'PGuuid) where pgtype = uuid-instance PGTyped schema (nullity 'PGjson) where pgtype = json-instance PGTyped schema (nullity 'PGjsonb) where pgtype = jsonb-instance PGTyped schema ty- => PGTyped schema (nullity ('PGvararray ty)) where- pgtype = vararray (pgtype @schema @ty)-instance (KnownNat n, PGTyped schema ty)- => PGTyped schema (nullity ('PGfixarray n ty)) where- pgtype = fixarray @n (pgtype @schema @ty)+Module: Squeal.PostgreSQL.Expression+Description: Squeal expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal expressions are the atoms used to build statements.+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MagicHash+ , OverloadedStrings+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+ , RankNTypes+#-}++module Squeal.PostgreSQL.Expression+ ( -- * Expression+ Expression (..)+ , Expr+ , (:-->)+ , unsafeFunction+ , unsafeUnaryOpL+ , unsafeUnaryOpR+ , Operator+ , unsafeBinaryOp+ , FunctionVar+ , unsafeFunctionVar+ , FunctionN+ , unsafeFunctionN+ , PGSubset (..)+ -- * Re-export+ , (&)+ , K (..)+ , unK+ ) where++import Control.Category+import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.Function ((&))+import Data.Semigroup hiding (All)+import Data.String+import Generics.SOP hiding (All, from)+import GHC.OverloadedLabels+import GHC.TypeLits+import Numeric+import Prelude hiding (id, (.))++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+column expressions+-----------------------------------------}++{- | `Expression`s are used in a variety of contexts,+such as in the target `Squeal.PostgreSQL.Query.List` of the+`Squeal.PostgreSQL.Query.select` command,+as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or+`Squeal.PostgreSQL.Manipulation.update`,+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.++The expression syntax allows the calculation of+values from primitive expression using arithmetic, logical,+and other operations.++The type parameters of `Expression` are++* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which+ the `Expression` is a correlated subquery expression;+* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s+ that are in scope for the `Expression`;+* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit+ which columns may be referenced by alias;+* @schemas :: @ `SchemasType`, the schemas of your database that are in+ scope for the `Expression`;+* @from :: @ `FromType`, the @from@ clause which the `Expression` may use+ to reference columns by alias;+* @ty :: @ `NullityType`, the type of the `Expression`.+-}+newtype Expression+ (outer :: FromType)+ (commons :: FromType)+ (grp :: Grouping)+ (schemas :: SchemasType)+ (params :: [NullityType])+ (from :: FromType)+ (ty :: NullityType)+ = UnsafeExpression { renderExpression :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL (Expression outer commons grp schemas params from ty) where+ renderSQL = renderExpression++-- | An `Expr` is a closed `Expression`.+-- It is a F@RankNType@ but don't be scared.+-- Think of it as an expression which sees no+-- namespaces, so you can't use parameters+-- or alias references. It can be used as+-- a simple piece of more complex `Expression`s.+type Expr x+ = forall outer commons grp schemas params from+ . Expression outer commons grp schemas params from x+ -- ^ cannot reference aliases++-- | A @RankNType@ for binary operators.+type Operator x1 x2 y+ = forall outer commons grp schemas params from+ . Expression outer commons grp schemas params from x1+ -- ^ left input+ -> Expression outer commons grp schemas params from x2+ -- ^ right input+ -> Expression outer commons grp schemas params from y+ -- ^ output++-- | A @RankNType@ for functions with a single argument.+-- These could be either function calls or unary operators.+-- This is a subtype of the usual Haskell function type `Prelude.->`,+-- indeed a subcategory as it is closed under the usual+-- `Prelude..` and `Prelude.id`.+type (:-->) x y+ = forall outer commons grp schemas params from+ . Expression outer commons grp schemas params from x+ -- ^ input+ -> Expression outer commons grp schemas params from y+ -- ^ output++{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.+Use the `*:` operator to end your argument lists, like so.++>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))+fun(TRUE, FALSE, LOCALTIME, TRUE)+-}+type FunctionN xs y+ = forall outer commons grp schemas params from+ . NP (Expression outer commons grp schemas params from) xs+ -- ^ inputs+ -> Expression outer commons grp schemas params from y+ -- ^ output++{- | A @RankNType@ for functions with a variable-length list of+homogeneous arguments and at least 1 more argument.+-}+type FunctionVar x0 x1 y+ = forall outer commons grp schemas params from+ . [Expression outer commons grp schemas params from x0]+ -- ^ inputs+ -> Expression outer commons grp schemas params from x1+ -- ^ must have at least 1 input+ -> Expression outer commons grp schemas params from y+ -- ^ output++{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)+greatest(TRUE, NULL, FALSE)+-}+unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y+unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized+ (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)++instance (HasUnique tab (Join outer from) row, Has col row ty)+ => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)+instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])+ => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where+ fromLabel = fromLabel @col :* Nil+instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))+ => IsLabel col+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where+ fromLabel = fromLabel @col `As` Alias+instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])+ => IsLabel col+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where+ fromLabel = fromLabel @col :* Nil++instance (Has tab (Join outer from) row, Has col row ty)+ => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where+ tab ! col = UnsafeExpression $+ renderSQL tab <> "." <> renderSQL col+instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])+ => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where+ tab ! col = tab ! col :* Nil+instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))+ => IsQualified tab col+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where+ tab ! col = tab ! col `As` col+instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])+ => IsQualified tab col+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where+ tab ! col = tab ! col :* Nil++instance+ ( HasUnique tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ ) => IsLabel col+ (Expression outer commons ('Grouped bys) schemas params from ty) where+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)+instance+ ( HasUnique tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ , tys ~ '[ty]+ ) => IsLabel col+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where+ fromLabel = fromLabel @col :* Nil+instance+ ( HasUnique tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ , column ~ (col ::: ty)+ ) => IsLabel col+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where+ fromLabel = fromLabel @col `As` Alias+instance+ ( HasUnique tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ , columns ~ '[col ::: ty]+ ) => IsLabel col+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where+ fromLabel = fromLabel @col :* Nil++instance+ ( Has tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ ) => IsQualified tab col+ (Expression outer commons ('Grouped bys) schemas params from ty) where+ tab ! col = UnsafeExpression $+ renderSQL tab <> "." <> renderSQL col+instance+ ( Has tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ , tys ~ '[ty]+ ) => IsQualified tab col+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where+ tab ! col = tab ! col :* Nil+instance+ ( Has tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ , column ~ (col ::: ty)+ ) => IsQualified tab col+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where+ tab ! col = tab ! col `As` col+instance+ ( Has tab (Join outer from) row+ , Has col row ty+ , GroupedBy tab col bys+ , columns ~ '[col ::: ty]+ ) => IsQualified tab col+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where+ tab ! col = tab ! col :* Nil++instance (KnownSymbol label, label `In` labels) => IsPGlabel label+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where+ label = UnsafeExpression $ renderSQL (PGlabel @label)++-- | >>> printSQL $ unsafeBinaryOp "OR" true false+-- (TRUE OR FALSE)+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2+unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $+ renderSQL x <+> op <+> renderSQL y++-- | >>> printSQL $ unsafeUnaryOpL "NOT" true+-- (NOT TRUE)+unsafeUnaryOpL :: ByteString -> x :--> y+unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x++-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"+-- (TRUE IS NOT TRUE)+unsafeUnaryOpR :: ByteString -> x :--> y+unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op++-- | >>> printSQL $ unsafeFunction "f" true+-- f(TRUE)+unsafeFunction :: ByteString -> x :--> y+unsafeFunction fun x = UnsafeExpression $+ fun <> parenthesized (renderSQL x)++-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')+-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')+unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y+unsafeFunctionN fun xs = UnsafeExpression $+ fun <> parenthesized (renderCommaSeparated renderSQL xs)++instance ty `In` PGNum+ => Num (Expression outer commons grp schemas params from (null ty)) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger+ = UnsafeExpression+ . fromString+ . show++instance (ty `In` PGNum, ty `In` PGFloating) => Fractional+ (Expression outer commons grp schemas params from (null ty)) where+ (/) = unsafeBinaryOp "/"+ fromRational+ = UnsafeExpression+ . fromString+ . ($ "")+ . showFFloat Nothing+ . fromRat @Double++instance (ty `In` PGNum, ty `In` PGFloating) => Floating+ (Expression outer commons grp schemas params from (null ty)) where+ pi = UnsafeExpression "pi()"+ exp = unsafeFunction "exp"+ log = unsafeFunction "ln"+ sqrt = unsafeFunction "sqrt"+ b ** x = UnsafeExpression $+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"+ logBase b y = log y / log b+ sin = unsafeFunction "sin"+ cos = unsafeFunction "cos"+ tan = unsafeFunction "tan"+ asin = unsafeFunction "asin"+ acos = unsafeFunction "acos"+ atan = unsafeFunction "atan"+ sinh x = (exp x - exp (-x)) / 2+ cosh x = (exp x + exp (-x)) / 2+ tanh x = sinh x / cosh x+ asinh x = log (x + sqrt (x*x + 1))+ acosh x = log (x + sqrt (x*x - 1))+ atanh x = log ((1 + x) / (1 - x)) / 2++-- | Contained by operators+class PGSubset container where+ (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)+ (@>) = unsafeBinaryOp "@>"+ (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)+ (<@) = unsafeBinaryOp "<@"+instance PGSubset 'PGjsonb+instance PGSubset 'PGtsquery+instance PGSubset ('PGvararray ty)++instance IsString+ (Expression outer commons grp schemas params from (null 'PGtext)) where+ fromString str = UnsafeExpression $+ "E\'" <> fromString (escape =<< str) <> "\'"+instance IsString+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $+ "E\'" <> fromString (escape =<< str) <> "\'"+instance IsString+ (Expression outer commons grp schemas params from (null 'PGtsquery)) where+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $+ "E\'" <> fromString (escape =<< str) <> "\'"++instance Semigroup+ (Expression outer commons grp schemas params from (null ('PGvararray ty))) where+ (<>) = unsafeBinaryOp "||"+instance Semigroup+ (Expression outer commons grp schemas params from (null 'PGjsonb)) where+ (<>) = unsafeBinaryOp "||"+instance Semigroup+ (Expression outer commons grp schemas params from (null 'PGtext)) where+ (<>) = unsafeBinaryOp "||"+instance Semigroup+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where+ (<>) = unsafeBinaryOp "||"++instance Monoid+ (Expression outer commons grp schemas params from (null 'PGtext)) where+ mempty = fromString ""+ mappend = (<>)+instance Monoid+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where+ mempty = fromString ""+ mappend = (<>)
+ src/Squeal/PostgreSQL/Expression/Aggregate.hs view
@@ -0,0 +1,447 @@+{-|+Module: Squeal.PostgreSQL.Expression.Aggregate+Description: Aggregate functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Aggregate functions+-}++{-# LANGUAGE+ DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Aggregate+ ( Aggregate (..)+ , Distinction (..)+ , PGAvg+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.Kind+import GHC.TypeLits++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- |+`Aggregate` functions compute a single result from a set of input values.+`Aggregate` functions can be used as `GroupedBy` `Expression`s as well+as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.+-}+class Aggregate expr1 exprN aggr+ | aggr -> expr1, aggr -> exprN where++ -- | A special aggregation that does not require an input+ --+ -- >>> :{+ -- let+ -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)+ -- expression = countStar+ -- in printSQL expression+ -- :}+ -- count(*)+ countStar :: aggr ('NotNull 'PGint8)++ -- | >>> :{+ -- let+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)+ -- expression = count (All #col)+ -- in printSQL expression+ -- :}+ -- count(ALL "col")+ count+ :: expr1 ty+ -- ^ what to count+ -> aggr ('NotNull 'PGint8)++ -- | >>> :{+ -- let+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)+ -- expression = sum_ (Distinct #col)+ -- in printSQL expression+ -- :}+ -- sum(DISTINCT "col")+ sum_+ :: ty `In` PGNum+ => expr1 (null ty)+ -> aggr ('Null ty)++ -- | input values, including nulls, concatenated into an array+ arrayAgg+ :: expr1 ty+ -> aggr ('Null ('PGvararray ty))++ -- | aggregates values as a JSON array+ jsonAgg+ :: expr1 ty+ -> aggr ('Null 'PGjson)++ -- | aggregates values as a JSON array+ jsonbAgg+ :: expr1 ty+ -> aggr ('Null 'PGjsonb)++ {- |+ the bitwise AND of all non-null input values, or null if none++ >>> :{+ let+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)+ expression = bitAnd (Distinct #col)+ in printSQL expression+ :}+ bit_and(DISTINCT "col")+ -}+ bitAnd+ :: int `In` PGIntegral+ => expr1 (null int)+ -- ^ what to aggregate+ -> aggr ('Null int)++ {- |+ the bitwise OR of all non-null input values, or null if none++ >>> :{+ let+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)+ expression = bitOr (All #col)+ in printSQL expression+ :}+ bit_or(ALL "col")+ -}+ bitOr+ :: int `In` PGIntegral+ => expr1 (null int)+ -- ^ what to aggregate+ -> aggr ('Null int)++ {- |+ true if all input values are true, otherwise false++ >>> :{+ let+ winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)+ winFun = boolAnd #col+ in printSQL winFun+ :}+ bool_and("col")+ -}+ boolAnd+ :: expr1 (null 'PGbool)+ -- ^ what to aggregate+ -> aggr ('Null 'PGbool)++ {- |+ true if at least one input value is true, otherwise false++ >>> :{+ let+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)+ expression = boolOr (All #col)+ in printSQL expression+ :}+ bool_or(ALL "col")+ -}+ boolOr+ :: expr1 (null 'PGbool)+ -- ^ what to aggregate+ -> aggr ('Null 'PGbool)++ {- |+ equivalent to `boolAnd`++ >>> :{+ let+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)+ expression = every (Distinct #col)+ in printSQL expression+ :}+ every(DISTINCT "col")+ -}+ every+ :: expr1 (null 'PGbool)+ -- ^ what to aggregate+ -> aggr ('Null 'PGbool)++ {- |maximum value of expression across all input values-}+ max_+ :: expr1 (null ty)+ -- ^ what to maximize+ -> aggr ('Null ty)++ -- | minimum value of expression across all input values+ min_+ :: expr1 (null ty)+ -- ^ what to minimize+ -> aggr ('Null ty)++ -- | the average (arithmetic mean) of all input values+ avg+ :: expr1 (null ty)+ -- ^ what to average+ -> aggr ('Null (PGAvg ty))++ {- | correlation coefficient++ >>> :{+ let+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = corr (All (#y *: #x))+ in printSQL expression+ :}+ corr(ALL "y", "x")+ -}+ corr+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ {- | population covariance++ >>> :{+ let+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = covarPop (All (#y *: #x))+ in printSQL expression+ :}+ covar_pop(ALL "y", "x")+ -}+ covarPop+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ {- | sample covariance++ >>> :{+ let+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ winFun = covarSamp (#y *: #x)+ in printSQL winFun+ :}+ covar_samp("y", "x")+ -}+ covarSamp+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ {- | average of the independent variable (sum(X)/N)++ >>> :{+ let+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = regrAvgX (All (#y *: #x))+ in printSQL expression+ :}+ regr_avgx(ALL "y", "x")+ -}+ regrAvgX+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ {- | average of the dependent variable (sum(Y)/N)++ >>> :{+ let+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ winFun = regrAvgY (#y *: #x)+ in printSQL winFun+ :}+ regr_avgy("y", "x")+ -}+ regrAvgY+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ {- | number of input rows in which both expressions are nonnull++ >>> :{+ let+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)+ winFun = regrCount (#y *: #x)+ in printSQL winFun+ :}+ regr_count("y", "x")+ -}+ regrCount+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGint8)++ {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs+ >>> :{+ let+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = regrIntercept (All (#y *: #x))+ in printSQL expression+ :}+ regr_intercept(ALL "y", "x")+ -}+ regrIntercept+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ -- | @regr_r2(Y, X)@, square of the correlation coefficient+ regrR2+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation+ -- determined by the (X, Y) pairs+ regrSlope+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N+ -- (“sum of squares” of the independent variable)+ regrSxx+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N+ -- (“sum of products” of independent times dependent variable)+ regrSxy+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N+ -- (“sum of squares” of the dependent variable)+ regrSyy+ :: exprN '[null 'PGfloat8, null 'PGfloat8]+ -> aggr ('Null 'PGfloat8)++ -- | historical alias for `stddevSamp`+ stddev+ :: expr1 (null ty)+ -> aggr ('Null (PGAvg ty))++ -- | population standard deviation of the input values+ stddevPop+ :: expr1 (null ty)+ -> aggr ('Null (PGAvg ty))++ -- | sample standard deviation of the input values+ stddevSamp+ :: expr1 (null ty)+ -> aggr ('Null (PGAvg ty))++ -- | historical alias for `varSamp`+ variance+ :: expr1 (null ty)+ -> aggr ('Null (PGAvg ty))++ -- | population variance of the input values+ -- (square of the population standard deviation)+ varPop+ :: expr1 (null ty)+ -> aggr ('Null (PGAvg ty))++ -- | sample variance of the input values+ -- (square of the sample standard deviation)+ varSamp+ :: expr1 (null ty)+ -> aggr ('Null (PGAvg ty))++{- |+`Distinction`s are used for the input of `Aggregate` `Expression`s.+`All` invokes the aggregate once for each input row.+`Distinct` invokes the aggregate once for each distinct value of the expression+(or distinct set of values, for multiple expressions) found in the input+-}+data Distinction (expr :: kind -> Type) (ty :: kind)+ = All (expr ty)+ | Distinct (expr ty)+ deriving (GHC.Generic,Show,Eq,Ord)+instance NFData (Distinction (Expression outer commons grp schemas params from) ty)+instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where+ renderSQL = \case+ All x -> "ALL" <+> renderSQL x+ Distinct x -> "DISTINCT" <+> renderSQL x+instance SOP.SListI tys => RenderSQL+ (Distinction (NP (Expression outer commons grp schemas params from)) tys) where+ renderSQL = \case+ All xs -> "ALL" <+> renderCommaSeparated renderSQL xs+ Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs++instance Aggregate+ (Distinction (Expression outer commons 'Ungrouped schemas params from))+ (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))+ (Expression outer commons ('Grouped bys) schemas params from) where+ countStar = UnsafeExpression "count(*)"+ count = unsafeAggregate1 "count"+ sum_ = unsafeAggregate1 "sum"+ arrayAgg = unsafeAggregate1 "array_agg"+ jsonAgg = unsafeAggregate1 "json_agg"+ jsonbAgg = unsafeAggregate1 "jsonb_agg"+ bitAnd = unsafeAggregate1 "bit_and"+ bitOr = unsafeAggregate1 "bit_or"+ boolAnd = unsafeAggregate1 "bool_and"+ boolOr = unsafeAggregate1 "bool_or"+ every = unsafeAggregate1 "every"+ max_ = unsafeAggregate1 "max"+ min_ = unsafeAggregate1 "min"+ avg = unsafeAggregate1 "avg"+ corr = unsafeAggregateN "corr"+ covarPop = unsafeAggregateN "covar_pop"+ covarSamp = unsafeAggregateN "covar_samp"+ regrAvgX = unsafeAggregateN "regr_avgx"+ regrAvgY = unsafeAggregateN "regr_avgy"+ regrCount = unsafeAggregateN "regr_count"+ regrIntercept = unsafeAggregateN "regr_intercept"+ regrR2 = unsafeAggregateN "regr_r2"+ regrSlope = unsafeAggregateN "regr_slope"+ regrSxx = unsafeAggregateN "regr_sxx"+ regrSxy = unsafeAggregateN "regr_sxy"+ regrSyy = unsafeAggregateN "regr_syy"+ stddev = unsafeAggregate1 "stddev"+ stddevPop = unsafeAggregate1 "stddev_pop"+ stddevSamp = unsafeAggregate1 "stddev_samp"+ variance = unsafeAggregate1 "variance"+ varPop = unsafeAggregate1 "var_pop"+ varSamp = unsafeAggregate1 "var_samp"++-- | escape hatch to define aggregate functions+unsafeAggregate1+ :: ByteString -- ^ aggregate function+ -> Distinction (Expression outer commons 'Ungrouped schemas params from) x+ -> Expression outer commons ('Grouped bys) schemas params from y+unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)++unsafeAggregateN+ :: SOP.SListI xs+ => ByteString -- ^ function+ -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs+ -> Expression outer commons ('Grouped bys) schemas params from y+unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)++-- | A type family that calculates `PGAvg` type of a `PGType`.+type family PGAvg ty where+ PGAvg 'PGint2 = 'PGnumeric+ PGAvg 'PGint4 = 'PGnumeric+ PGAvg 'PGint8 = 'PGnumeric+ PGAvg 'PGnumeric = 'PGnumeric+ PGAvg 'PGfloat4 = 'PGfloat8+ PGAvg 'PGfloat8 = 'PGfloat8+ PGAvg 'PGinterval = 'PGinterval+ PGAvg pg = TypeError+ ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
+ src/Squeal/PostgreSQL/Expression/Collection.hs view
@@ -0,0 +1,169 @@+{-|+Module: Squeal.PostgreSQL.Expression.Collection+Description: Array and composite functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Array and composite functions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Collection+ ( array+ , array1+ , array2+ , cardinality+ , index+ , unnest+ , row+ , field+ ) where++import Data.String+import Data.Word (Word64)++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.SetOf+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | >>> printSQL $ array [null_, false, true]+-- ARRAY[NULL, FALSE, TRUE]+array+ :: [Expression outer commons grp schemas params from ty]+ -- ^ array elements+ -> Expression outer commons grp schemas params from (null ('PGvararray ty))+array xs = UnsafeExpression $ "ARRAY" <>+ bracketed (commaSeparated (renderSQL <$> xs))++{- | construct a 1-dimensional fixed length array++>>> printSQL $ array1 (null_ :* false *: true)+ARRAY[NULL, FALSE, TRUE]++>>> :type array1 (null_ :* false *: true)+array1 (null_ :* false *: true)+ :: Expression+ outer+ commons+ grp+ schemas+ params+ from+ (null ('PGfixarray '[3] ('Null 'PGbool)))+-}+array1+ :: (n ~ Length tys, SOP.All ((~) ty) tys)+ => NP (Expression outer commons grp schemas params from) tys+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))+array1 xs = UnsafeExpression $ "ARRAY" <>+ bracketed (renderCommaSeparated renderSQL xs)++{- | construct a 2-dimensional fixed length array++>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))+ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]++>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))+array2 ((null_ :* false *: true) *: (false :* null_ *: true))+ :: Expression+ outer+ commons+ grp+ schemas+ params+ from+ (null ('PGfixarray '[2, 3] ('Null 'PGbool)))+-}+array2+ :: ( SOP.All ((~) tys) tyss+ , SOP.All SOP.SListI tyss+ , Length tyss ~ n1+ , SOP.All ((~) ty) tys+ , Length tys ~ n2 )+ => NP (NP (Expression outer commons grp schemas params from)) tyss+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))+array2 xss = UnsafeExpression $ "ARRAY" <>+ bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)++-- | >>> printSQL $ cardinality (array [null_, false, true])+-- cardinality(ARRAY[NULL, FALSE, TRUE])+cardinality :: null ('PGvararray ty) :--> null 'PGint8+cardinality = unsafeFunction "cardinality"++-- | >>> printSQL $ array [null_, false, true] & index 2+-- (ARRAY[NULL, FALSE, TRUE])[2]+index+ :: Word64 -- ^ index+ -> null ('PGvararray ty) :--> NullifyType ty+index n expr = UnsafeExpression $+ parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"++-- | Expand an array to a set of rows+unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]+unnest = unsafeSetOfFunction++-- | A row constructor is an expression that builds a row value+-- (also called a composite value) using values for its member fields.+--+-- >>> :{+-- type Complex = 'PGcomposite+-- '[ "real" ::: 'NotNull 'PGfloat8+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]+-- :}+--+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)+-- >>> printSQL i+-- ROW(0, 1)+row+ :: SOP.SListI row+ => NP (Aliased (Expression outer commons grp schemas params from)) row+ -- ^ zero or more expressions for the row field values+ -> Expression outer commons grp schemas params from (null ('PGcomposite row))+row exprs = UnsafeExpression $ "ROW" <> parenthesized+ (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)++-- | >>> :{+-- type Complex = 'PGcomposite+-- '[ "real" ::: 'NotNull 'PGfloat8+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]+-- type Schema = '["complex" ::: 'Typedef Complex]+-- :}+--+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)+-- >>> printSQL $ i & field #complex #imaginary+-- (ROW(0, 1)::"complex")."imaginary"+field+ :: ( Has sch schemas schema+ , Has tydef schema ('Typedef ('PGcomposite row))+ , Has field row ty)+ => QualifiedAlias sch tydef -- ^ row type+ -> Alias field -- ^ field name+ -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))+ -> Expression outer commons grp schemas params from ty+field td fld expr = UnsafeExpression $+ parenthesized (renderSQL expr <> "::" <> renderSQL td)+ <> "." <> renderSQL fld
+ src/Squeal/PostgreSQL/Expression/Comparison.hs view
@@ -0,0 +1,206 @@+{-|+Module: Squeal.PostgreSQL.Expression.Comparison+Description: Comparison expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Comparison functions and operators+-}++{-# LANGUAGE+ OverloadedStrings+ , RankNTypes+ , TypeInType+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Comparison+ ( (.==)+ , (./=)+ , (.>=)+ , (.<)+ , (.<=)+ , (.>)+ , greatest+ , least+ , BetweenExpr+ , between+ , notBetween+ , betweenSymmetric+ , notBetweenSymmetric+ , isDistinctFrom+ , isNotDistinctFrom+ , isTrue+ , isNotTrue+ , isFalse+ , isNotFalse+ , isUnknown+ , isNotUnknown+ ) where++import Data.ByteString++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`+-- will produce @NULL@s if one of their arguments is @NULL@.+--+-- >>> printSQL $ true .== null_+-- (TRUE = NULL)+(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+(.==) = unsafeBinaryOp "="+infix 4 .==++-- | >>> printSQL $ true ./= null_+-- (TRUE <> NULL)+(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+(./=) = unsafeBinaryOp "<>"+infix 4 ./=++-- | >>> printSQL $ true .>= null_+-- (TRUE >= NULL)+(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+(.>=) = unsafeBinaryOp ">="+infix 4 .>=++-- | >>> printSQL $ true .< null_+-- (TRUE < NULL)+(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+(.<) = unsafeBinaryOp "<"+infix 4 .<++-- | >>> printSQL $ true .<= null_+-- (TRUE <= NULL)+(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+(.<=) = unsafeBinaryOp "<="+infix 4 .<=++-- | >>> printSQL $ true .> null_+-- (TRUE > NULL)+(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+(.>) = unsafeBinaryOp ">"+infix 4 .>++-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)+-- >>> printSQL expr+-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)+greatest :: FunctionVar ty ty ty+greatest = unsafeFunctionVar "GREATEST"++-- | >>> printSQL $ least [null_] currentTimestamp+-- LEAST(NULL, CURRENT_TIMESTAMP)+least :: FunctionVar ty ty ty+least = unsafeFunctionVar "LEAST"++{- |+A @RankNType@ for comparison expressions like `between`.+-}+type BetweenExpr+ = forall outer commons grp schemas params from ty+ . Expression outer commons grp schemas params from ty+ -> ( Expression outer commons grp schemas params from ty+ , Expression outer commons grp schemas params from ty ) -- ^ bounds+ -> Condition outer commons grp schemas params from++unsafeBetweenExpr :: ByteString -> BetweenExpr+unsafeBetweenExpr fun a (x,y) = UnsafeExpression $+ renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y++{- | >>> printSQL $ true `between` (null_, false)+TRUE BETWEEN NULL AND FALSE+-}+between :: BetweenExpr+between = unsafeBetweenExpr "BETWEEN"++{- | >>> printSQL $ true `notBetween` (null_, false)+TRUE NOT BETWEEN NULL AND FALSE+-}+notBetween :: BetweenExpr+notBetween = unsafeBetweenExpr "NOT BETWEEN"++{- | between, after sorting the comparison values++>>> printSQL $ true `betweenSymmetric` (null_, false)+TRUE BETWEEN SYMMETRIC NULL AND FALSE+-}+betweenSymmetric :: BetweenExpr+betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"++{- | not between, after sorting the comparison values++>>> printSQL $ true `notBetweenSymmetric` (null_, false)+TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE+-}+notBetweenSymmetric :: BetweenExpr+notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"++{- | not equal, treating null like an ordinary value++>>> printSQL $ true `isDistinctFrom` null_+(TRUE IS DISTINCT FROM NULL)+-}+isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"++{- | equal, treating null like an ordinary value++>>> printSQL $ true `isNotDistinctFrom` null_+(TRUE IS NOT DISTINCT FROM NULL)+-}+isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)+isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"++{- | is true++>>> printSQL $ true & isTrue+(TRUE IS TRUE)+-}+isTrue :: null0 'PGbool :--> null1 'PGbool+isTrue = unsafeUnaryOpR "IS TRUE"++{- | is false or unknown++>>> printSQL $ true & isNotTrue+(TRUE IS NOT TRUE)+-}+isNotTrue :: null0 'PGbool :--> null1 'PGbool+isNotTrue = unsafeUnaryOpR "IS NOT TRUE"++{- | is false++>>> printSQL $ true & isFalse+(TRUE IS FALSE)+-}+isFalse :: null0 'PGbool :--> null1 'PGbool+isFalse = unsafeUnaryOpR "IS FALSE"++{- | is true or unknown++>>> printSQL $ true & isNotFalse+(TRUE IS NOT FALSE)+-}+isNotFalse :: null0 'PGbool :--> null1 'PGbool+isNotFalse = unsafeUnaryOpR "IS NOT FALSE"++{- | is unknown++>>> printSQL $ true & isUnknown+(TRUE IS UNKNOWN)+-}+isUnknown :: null0 'PGbool :--> null1 'PGbool+isUnknown = unsafeUnaryOpR "IS UNKNOWN"++{- | is true or false++>>> printSQL $ true & isNotUnknown+(TRUE IS NOT UNKNOWN)+-}+isNotUnknown :: null0 'PGbool :--> null1 'PGbool+isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"
+ src/Squeal/PostgreSQL/Expression/Json.hs view
@@ -0,0 +1,469 @@+{-|+Module: Squeal.PostgreSQL.Expression.Json+Description: Json and Jsonb functions and operators+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Json and Jsonb functions and operators+-}++{-# LANGUAGE+ DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , OverloadedLabels+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Expression.Json+ ( -- * Json and Jsonb operators+ (.->)+ , (.->>)+ , (.#>)+ , (.#>>)+ -- * Jsonb operators+ , (.?)+ , (.?|)+ , (.?&)+ , (.-.)+ , (#-.)+ -- * Json and Jsonb functions+ , toJson+ , toJsonb+ , arrayToJson+ , rowToJson+ , jsonBuildArray+ , jsonbBuildArray+ , JsonBuildObject (..)+ , jsonObject+ , jsonbObject+ , jsonZipObject+ , jsonbZipObject+ , jsonArrayLength+ , jsonbArrayLength+ , jsonTypeof+ , jsonbTypeof+ , jsonStripNulls+ , jsonbStripNulls+ , jsonbSet+ , jsonbInsert+ , jsonbPretty+ -- * Json and Jsonb set returning functions+ , jsonEach+ , jsonbEach+ , jsonEachText+ , jsonbEachText+ , jsonObjectKeys+ , jsonbObjectKeys+ , JsonPopulateFunction+ , jsonPopulateRecord+ , jsonbPopulateRecord+ , jsonPopulateRecordSet+ , jsonbPopulateRecordSet+ , JsonToRecordFunction+ , jsonToRecord+ , jsonbToRecord+ , jsonToRecordSet+ , jsonbToRecordSet+ ) where++import Data.ByteString (ByteString)+import GHC.TypeLits++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.SetOf+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++import qualified Generics.SOP as SOP++-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> import Data.Aeson++{-----------------------------------------+ -- json and jsonb support++See https://www.postgresql.org/docs/10/static/functions-json.html -- most+comments lifted directly from this page.++Table 9.44: json and jsonb operators+-----------------------------------------}++-- | Get JSON value (object field or array element) at a key.+(.->)+ :: (json `In` PGJsonType, key `In` PGJsonKey)+ => Operator (null json) (null key) ('Null json)+infixl 8 .->+(.->) = unsafeBinaryOp "->"++-- | Get JSON value (object field or array element) at a key, as text.+(.->>)+ :: (json `In` PGJsonType, key `In` PGJsonKey)+ => Operator (null json) (null key) ('Null 'PGtext)+infixl 8 .->>+(.->>) = unsafeBinaryOp "->>"++-- | Get JSON value at a specified path.+(.#>)+ :: json `In` PGJsonType+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)+infixl 8 .#>+(.#>) = unsafeBinaryOp "#>"++-- | Get JSON value at a specified path as text.+(.#>>)+ :: json `In` PGJsonType+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)+infixl 8 .#>>+(.#>>) = unsafeBinaryOp "#>>"++-- Additional jsonb operators++-- | Does the string exist as a top-level key within the JSON value?+(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)+infixl 9 .?+(.?) = unsafeBinaryOp "?"++-- | Do any of these array strings exist as top-level keys?+(.?|) :: Operator+ (null 'PGjsonb)+ (null ('PGvararray ('NotNull 'PGtext)))+ ('Null 'PGbool)+infixl 9 .?|+(.?|) = unsafeBinaryOp "?|"++-- | Do all of these array strings exist as top-level keys?+(.?&) :: Operator+ (null 'PGjsonb)+ (null ('PGvararray ('NotNull 'PGtext)))+ ('Null 'PGbool)+infixl 9 .?&+(.?&) = unsafeBinaryOp "?&"++-- | Delete a key or keys from a JSON object, or remove an array element.+--+-- If the right operand is+--+-- @ text @: Delete key / value pair or string element from left operand.+-- Key / value pairs are matched based on their key value,+--+-- @ text[] @: Delete multiple key / value pairs or string elements+-- from left operand. Key / value pairs are matched based on their key value,+--+-- @ integer @: Delete the array element with specified index (Negative integers+-- count from the end). Throws an error if top level container is not an array.+(.-.)+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]+ => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)+infixl 6 .-.+(.-.) = unsafeBinaryOp "-"++-- | Delete the field or element with specified path (for JSON arrays, negative+-- integers count from the end)+(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)+infixl 6 #-.+(#-.) = unsafeBinaryOp "#-"++{-----------------------------------------+Table 9.45: JSON creation functions+-----------------------------------------}++-- | Returns the value as json. Arrays and composites are converted+-- (recursively) to arrays and objects; otherwise, if there is a cast from the+-- type to json, the cast function will be used to perform the conversion;+-- otherwise, a scalar value is produced. For any scalar type other than a+-- number, a Boolean, or a null value, the text representation will be used, in+-- such a fashion that it is a valid json value.+toJson :: null ty :--> null 'PGjson+toJson = unsafeFunction "to_json"++-- | Returns the value as jsonb. Arrays and composites are converted+-- (recursively) to arrays and objects; otherwise, if there is a cast from the+-- type to json, the cast function will be used to perform the conversion;+-- otherwise, a scalar value is produced. For any scalar type other than a+-- number, a Boolean, or a null value, the text representation will be used, in+-- such a fashion that it is a valid jsonb value.+toJsonb :: null ty :--> null 'PGjsonb+toJsonb = unsafeFunction "to_jsonb"++-- | Returns the array as a JSON array. A PostgreSQL multidimensional array+-- becomes a JSON array of arrays.+arrayToJson :: null ('PGvararray ty) :--> null 'PGjson+arrayToJson = unsafeFunction "array_to_json"++-- | Returns the row as a JSON object.+rowToJson :: null ('PGcomposite ty) :--> null 'PGjson+rowToJson = unsafeFunction "row_to_json"++-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic+-- argument list.+jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)+jsonBuildArray = unsafeFunctionN "json_build_array"++-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a+-- variadic argument list.+jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)+jsonbBuildArray = unsafeFunctionN "jsonb_build_array"++-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic+-- argument list. The elements of the argument list must alternate between text+-- and values.+class SOP.SListI tys => JsonBuildObject tys where++ jsonBuildObject :: FunctionN tys (null 'PGjson)+ jsonBuildObject = unsafeFunctionN "json_build_object"++ jsonbBuildObject :: FunctionN tys (null 'PGjsonb)+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"++instance JsonBuildObject '[]+instance (JsonBuildObject tys, key `In` PGJsonKey)+ => JsonBuildObject ('NotNull key ': value ': tys)++-- | Builds a JSON object out of a text array.+-- The array must have two dimensions+-- such that each inner array has exactly two elements,+-- which are taken as a key/value pair.+jsonObject+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))+ :--> null 'PGjson+jsonObject = unsafeFunction "json_object"++-- | Builds a binary JSON object out of a text array.+-- The array must have two dimensions+-- such that each inner array has exactly two elements,+-- which are taken as a key/value pair.+jsonbObject+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))+ :--> null 'PGjsonb+jsonbObject = unsafeFunction "jsonb_object"++-- | This is an alternate form of 'jsonObject' that takes two arrays; one for+-- keys and one for values, that are zipped pairwise to create a JSON object.+jsonZipObject :: FunctionN+ '[ null ('PGvararray ('NotNull 'PGtext))+ , null ('PGvararray ('NotNull 'PGtext)) ]+ ( null 'PGjson )+jsonZipObject = unsafeFunctionN "json_object"++-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for+-- keys and one for values, that are zipped pairwise to create a binary JSON+-- object.+jsonbZipObject :: FunctionN+ '[ null ('PGvararray ('NotNull 'PGtext))+ , null ('PGvararray ('NotNull 'PGtext)) ]+ ( null 'PGjsonb )+jsonbZipObject = unsafeFunctionN "jsonb_object"++{-----------------------------------------+Table 9.46: JSON processing functions+-----------------------------------------}++-- | Returns the number of elements in the outermost JSON array.+jsonArrayLength :: null 'PGjson :--> null 'PGint4+jsonArrayLength = unsafeFunction "json_array_length"++-- | Returns the number of elements in the outermost binary JSON array.+jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4+jsonbArrayLength = unsafeFunction "jsonb_array_length"++-- | Returns the type of the outermost JSON value as a text string. Possible+-- types are object, array, string, number, boolean, and null.+jsonTypeof :: null 'PGjson :--> null 'PGtext+jsonTypeof = unsafeFunction "json_typeof"++-- | Returns the type of the outermost binary JSON value as a text string.+-- Possible types are object, array, string, number, boolean, and null.+jsonbTypeof :: null 'PGjsonb :--> null 'PGtext+jsonbTypeof = unsafeFunction "jsonb_typeof"++-- | Returns its argument with all object fields that have null values omitted.+-- Other null values are untouched.+jsonStripNulls :: null 'PGjson :--> null 'PGjson+jsonStripNulls = unsafeFunction "json_strip_nulls"++-- | Returns its argument with all object fields that have null values omitted.+-- Other null values are untouched.+jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb+jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"++-- | @ jsonbSet target path new_value create_missing @+--+-- Returns target with the section designated by path replaced by @new_value@,+-- or with @new_value@ added if create_missing is+-- `Squeal.PostgreSQL.Expression.Logic.true` and the+-- item designated by path does not exist. As with the path orientated+-- operators, negative integers that appear in path count from the end of JSON+-- arrays.+jsonbSet+ :: FunctionN+ '[ null 'PGjsonb+ , null ('PGvararray ('NotNull 'PGtext))+ , null 'PGjsonb+ , null 'PGbool ] (null 'PGjsonb)+jsonbSet = unsafeFunctionN "jsonbSet"++-- | @ jsonbInsert target path new_value insert_after @+--+-- Returns target with @new_value@ inserted. If target section designated by+-- path is in a JSONB array, @new_value@ will be inserted before target or after+-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.+-- If target section designated by+-- path is in JSONB object, @new_value@ will be inserted only if target does not+-- exist. As with the path orientated operators, negative integers that appear+-- in path count from the end of JSON arrays.+jsonbInsert+ :: FunctionN+ '[ null 'PGjsonb+ , null ('PGvararray ('NotNull 'PGtext))+ , null 'PGjsonb+ , null 'PGbool ] (null 'PGjsonb)+jsonbInsert = unsafeFunctionN "jsonb_insert"++-- | Returns its argument as indented JSON text.+jsonbPretty :: null 'PGjsonb :--> null 'PGtext+jsonbPretty = unsafeFunction "jsonb_pretty"+++{- | Expands the outermost JSON object into a set of key/value pairs.++>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))+SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))+-}+jsonEach :: SetOfFunction "json_each" (null 'PGjson)+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]+jsonEach = unsafeSetOfFunction++{- | Expands the outermost binary JSON object into a set of key/value pairs.++>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))+SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))+-}+jsonbEach+ :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]+jsonbEach = unsafeSetOfFunction++{- | Expands the outermost JSON object into a set of key/value pairs.++>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))+SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))+-}+jsonEachText+ :: SetOfFunction "json_each_text" (null 'PGjson)+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]+jsonEachText = unsafeSetOfFunction++{- | Expands the outermost binary JSON object into a set of key/value pairs.++>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))+SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))+-}+jsonbEachText+ :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]+jsonbEachText = unsafeSetOfFunction++{- | Returns set of keys in the outermost JSON object.++>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))+json_object_keys(('{"a":"foo","b":"bar"}' :: json))+-}+jsonObjectKeys+ :: SetOfFunction "json_object_keys" (nullity 'PGjson)+ '["json_object_keys" ::: 'NotNull 'PGtext]+jsonObjectKeys = unsafeSetOfFunction++{- | Returns set of keys in the outermost JSON object.++>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))+jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))+-}+jsonbObjectKeys+ :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)+ '["jsonb_object_keys" ::: 'NotNull 'PGtext]+jsonbObjectKeys = unsafeSetOfFunction++-- | Build rows from Json types.+type JsonPopulateFunction fun json+ = forall schemas row outer commons params+ . json `In` PGJsonType+ => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type+ -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)+ -- ^ json type+ -> FromClause outer commons schemas params '[fun ::: row]++unsafePopulateFunction+ :: forall fun ty+ . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty+unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun+ <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)++-- | Expands the JSON expression to a row whose columns match the record+-- type defined by the given table.+jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson+jsonPopulateRecord = unsafePopulateFunction #json_populate_record++-- | Expands the binary JSON expression to a row whose columns match the record+-- type defined by the given table.+jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb+jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record++-- | Expands the outermost array of objects in the given JSON expression to a+-- set of rows whose columns match the record type defined by the given table.+jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson+jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set++-- | Expands the outermost array of objects in the given binary JSON expression+-- to a set of rows whose columns match the record type defined by the given+-- table.+jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb+jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set++-- | Build rows from Json types.+type JsonToRecordFunction json+ = forall outer commons schemas params tab row+ . (SOP.SListI row, json `In` PGJsonType)+ => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)+ -- ^ json type+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)+ -- ^ row type+ -> FromClause outer commons schemas params '[tab ::: row]++unsafeRecordFunction :: ByteString -> JsonToRecordFunction json+unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $+ fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab+ <> parenthesized (renderCommaSeparated renderTy types)+ where+ renderTy :: Aliased (TypeExpression schemas) ty -> ByteString+ renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty++-- | Builds an arbitrary record from a JSON object.+jsonToRecord :: JsonToRecordFunction 'PGjson+jsonToRecord = unsafeRecordFunction "json_to_record"++-- | Builds an arbitrary record from a binary JSON object.+jsonbToRecord :: JsonToRecordFunction 'PGjsonb+jsonbToRecord = unsafeRecordFunction "jsonb_to_record"++-- | Builds an arbitrary set of records from a JSON array of objects.+jsonToRecordSet :: JsonToRecordFunction 'PGjson+jsonToRecordSet = unsafeRecordFunction "json_to_record_set"++-- | Builds an arbitrary set of records from a binary JSON array of objects.+jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb+jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
+ src/Squeal/PostgreSQL/Expression/Literal.hs view
@@ -0,0 +1,87 @@+{-|+Module: Squeal.PostgreSQL.Expression.Literal+Description: Literal expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Literal expressions+-}++{-# LANGUAGE+ FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeSynonymInstances+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where++import ByteString.StrictBuilder (builderBytes)+import Data.ByteString.Lazy (toStrict)+import Data.Int+import Data.String+import Data.Text (Text)++import qualified Data.Aeson as JSON+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy (Text)+import qualified Data.Text.Lazy as Lazy.Text++import Squeal.PostgreSQL.Binary+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.PG+import Squeal.PostgreSQL.Render++{- |+The `Literal` class allows embedding a Haskell value directly+as an `Expression` using `literal`.++>>> printSQL (literal 'a')+E'a'++>>> printSQL (literal (1 :: Double))+1.0++>>> printSQL (literal (Json [1 :: Double, 2]))+('[1.0,2.0]' :: json)++>>> printSQL (literal (Enumerated GT))+'GT'+-}+class Literal hask where literal :: hask -> Expr (null (PG hask))+instance Literal Bool where+ literal = \case+ True -> true+ False -> false+instance JSON.ToJSON hask => Literal (Json hask) where+ literal = UnsafeExpression . parenthesized . (<> " :: json")+ . singleQuotedUtf8 . toStrict . JSON.encode . getJson+instance JSON.ToJSON hask => Literal (Jsonb hask) where+ literal = UnsafeExpression . parenthesized . (<> " :: jsonb")+ . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb+instance Literal Char where+ literal chr = UnsafeExpression $+ "E\'" <> fromString (escape chr) <> "\'"+instance Literal String where literal = fromString+instance Literal Int16 where literal = fromIntegral+instance Literal Int32 where literal = fromIntegral+instance Literal Int64 where literal = fromIntegral+instance Literal Float where literal = fromRational . toRational+instance Literal Double where literal = fromRational . toRational+instance Literal Text where literal = fromString . Text.unpack+instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack+instance ToParam (Enumerated enum) (PG (Enumerated enum))+ => Literal (Enumerated enum) where+ literal+ = UnsafeExpression+ . singleQuotedUtf8+ . builderBytes+ . unK+ . toParam @(Enumerated enum) @(PG (Enumerated enum))
+ src/Squeal/PostgreSQL/Expression/Logic.hs view
@@ -0,0 +1,105 @@+{-|+Module: Squeal.PostgreSQL.Expression.Logic+Description: Logical expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Logical expressions and operators+-}++{-# LANGUAGE+ DataKinds+ , OverloadedStrings+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Logic+ ( Condition+ , true+ , false+ , not_+ , (.&&)+ , (.||)+ , caseWhenThenElse+ , ifThenElse+ ) where++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- | A `Condition` is an `Expression`, which can evaluate+-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses+-- a three valued logic.+type Condition outer commons grp schemas params from =+ Expression outer commons grp schemas params from ('Null 'PGbool)++-- | >>> printSQL true+-- TRUE+true :: Expr (null 'PGbool)+true = UnsafeExpression "TRUE"++-- | >>> printSQL false+-- FALSE+false :: Expr (null 'PGbool)+false = UnsafeExpression "FALSE"++-- | >>> printSQL $ not_ true+-- (NOT TRUE)+not_ :: null 'PGbool :--> null 'PGbool+not_ = unsafeUnaryOpL "NOT"++-- | >>> printSQL $ true .&& false+-- (TRUE AND FALSE)+(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)+infixr 3 .&&+(.&&) = unsafeBinaryOp "AND"++-- | >>> printSQL $ true .|| false+-- (TRUE OR FALSE)+(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)+infixr 2 .||+(.||) = unsafeBinaryOp "OR"++-- | >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3+-- in printSQL expression+-- :}+-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END+caseWhenThenElse+ :: [ ( Condition outer commons grp schemas params from+ , Expression outer commons grp schemas params from ty+ ) ]+ -- ^ whens and thens+ -> Expression outer commons grp schemas params from ty+ -- ^ else+ -> Expression outer commons grp schemas params from ty+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat+ [ "CASE"+ , mconcat+ [ mconcat+ [ " WHEN ", renderSQL when_+ , " THEN ", renderSQL then_+ ]+ | (when_,then_) <- whenThens+ ]+ , " ELSE ", renderSQL else_+ , " END"+ ]++-- | >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression = ifThenElse true 1 0+-- in printSQL expression+-- :}+-- CASE WHEN TRUE THEN 1 ELSE 0 END+ifThenElse+ :: Condition outer commons grp schemas params from+ -> Expression outer commons grp schemas params from ty -- ^ then+ -> Expression outer commons grp schemas params from ty -- ^ else+ -> Expression outer commons grp schemas params from ty+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
+ src/Squeal/PostgreSQL/Expression/Math.hs view
@@ -0,0 +1,102 @@+{-|+Module: Squeal.PostgreSQL.Expression.Math+Description: Math expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Mathematical functions and operators+-}++{-# LANGUAGE+ DataKinds+ , OverloadedStrings+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Math+ ( atan2_+ , quot_+ , rem_+ , trunc+ , round_+ , ceiling_+ ) where++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | >>> :{+-- let+-- expression :: Expr (null 'PGfloat4)+-- expression = atan2_ (pi *: 2)+-- in printSQL expression+-- :}+-- atan2(pi(), 2)+atan2_+ :: float `In` PGFloating+ => FunctionN '[ null float, null float] (null float)+atan2_ = unsafeFunctionN "atan2"+++-- | integer division, truncates the result+--+-- >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression = 5 `quot_` 2+-- in printSQL expression+-- :}+-- (5 / 2)+quot_+ :: int `In` PGIntegral+ => Operator (null int) (null int) (null int)+quot_ = unsafeBinaryOp "/"++-- | remainder upon integer division+--+-- >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression = 5 `rem_` 2+-- in printSQL expression+-- :}+-- (5 % 2)+rem_+ :: int `In` PGIntegral+ => Operator (null int) (null int) (null int)+rem_ = unsafeBinaryOp "%"++-- | >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)+-- expression = trunc pi+-- in printSQL expression+-- :}+-- trunc(pi())+trunc :: frac `In` PGFloating => null frac :--> null frac+trunc = unsafeFunction "trunc"++-- | >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)+-- expression = round_ pi+-- in printSQL expression+-- :}+-- round(pi())+round_ :: frac `In` PGFloating => null frac :--> null frac+round_ = unsafeFunction "round"++-- | >>> :{+-- let+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)+-- expression = ceiling_ pi+-- in printSQL expression+-- :}+-- ceiling(pi())+ceiling_ :: frac `In` PGFloating => null frac :--> null frac+ceiling_ = unsafeFunction "ceiling"
+ src/Squeal/PostgreSQL/Expression/Null.hs view
@@ -0,0 +1,104 @@+{-|+Module: Squeal.PostgreSQL.Expression.Null+Description: Null+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Null values and null handling functions+-}++{-# LANGUAGE+ DataKinds+ , OverloadedStrings+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Null+ ( null_+ , notNull+ , coalesce+ , fromNull+ , isNull+ , isNotNull+ , matchNull+ , nullIf+ ) where++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | analagous to `Nothing`+--+-- >>> printSQL null_+-- NULL+null_ :: Expr ('Null ty)+null_ = UnsafeExpression "NULL"++-- | analagous to `Just`+--+-- >>> printSQL $ notNull true+-- TRUE+notNull :: 'NotNull ty :--> 'Null ty+notNull = UnsafeExpression . renderSQL++-- | return the leftmost value which is not NULL+--+-- >>> printSQL $ coalesce [null_, true] false+-- COALESCE(NULL, TRUE, FALSE)+coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)+coalesce nullxs notNullx = UnsafeExpression $+ "COALESCE" <> parenthesized (commaSeparated+ ((renderSQL <$> nullxs) <> [renderSQL notNullx]))++-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@+--+-- >>> printSQL $ fromNull true null_+-- COALESCE(NULL, TRUE)+fromNull+ :: Expression outer commons grp schemas params from ('NotNull ty)+ -- ^ what to convert @NULL@ to+ -> Expression outer commons grp schemas params from ('Null ty)+ -> Expression outer commons grp schemas params from ('NotNull ty)+fromNull notNullx nullx = coalesce [nullx] notNullx++-- | >>> printSQL $ null_ & isNull+-- NULL IS NULL+isNull :: 'Null ty :--> null 'PGbool+isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"++-- | >>> printSQL $ null_ & isNotNull+-- NULL IS NOT NULL+isNotNull :: 'Null ty :--> null 'PGbool+isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"++-- | analagous to `maybe` using @IS NULL@+--+-- >>> printSQL $ matchNull true not_ null_+-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END+matchNull+ :: Expression outer commons grp schemas params from (nullty)+ -- ^ what to convert @NULL@ to+ -> ( Expression outer commons grp schemas params from ('NotNull ty)+ -> Expression outer commons grp schemas params from (nullty) )+ -- ^ function to perform when @NULL@ is absent+ -> Expression outer commons grp schemas params from ('Null ty)+ -> Expression outer commons grp schemas params from (nullty)+matchNull y f x = ifThenElse (isNull x) y+ (f (UnsafeExpression (renderSQL x)))++{-| right inverse to `fromNull`, if its arguments are equal then+`nullIf` gives @NULL@.++>>> :set -XTypeApplications -XDataKinds+>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)+>>> printSQL expr+NULLIF(FALSE, ($1 :: bool))+-}+nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)+nullIf = unsafeFunctionN "NULLIF"
+ src/Squeal/PostgreSQL/Expression/Parameter.hs view
@@ -0,0 +1,80 @@+{-|+Module: Squeal.PostgreSQL.Expression.Parameter+Description: Parameters+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Parameters, out-of-line data values+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Parameter+ ( HasParameter (parameter)+ , param+ ) where++import GHC.TypeLits++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | A `HasParameter` constraint is used to indicate a value that is+supplied externally to a SQL statement.+`Squeal.PostgreSQL.PQ.manipulateParams`,+`Squeal.PostgreSQL.PQ.queryParams` and+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values+separately from the SQL command string, in which case `param`s are used to+refer to the out-of-line data values.+-}+class KnownNat n => HasParameter+ (n :: Nat)+ (params :: [NullityType])+ (ty :: NullityType)+ | n params -> ty where+ -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.+ --+ -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)+ -- >>> printSQL expr+ -- ($1 :: int4)+ parameter+ :: TypeExpression schemas ty+ -> Expression outer commons grp schemas params from ty+ 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++-- | `param` takes a `Nat` using type application and for basic types,+-- infers a `TypeExpression`.+--+-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)+-- >>> printSQL expr+-- ($1 :: int4)+param+ :: forall n outer commons schemas params from grp ty+ . (PGTyped schemas ty, HasParameter n params ty)+ => Expression outer commons grp schemas params from ty -- ^ param+param = parameter @n (pgtype @schemas)
+ src/Squeal/PostgreSQL/Expression/SetOf.hs view
@@ -0,0 +1,106 @@+{-|+Module: Squeal.PostgreSQL.Expression.SetOf+Description: Set returning functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Set returning functions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , FlexibleContexts+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.SetOf+ ( generateSeries+ , generateSeriesStep+ , generateSeriesTimestamp+ , SetOfFunction+ , unsafeSetOfFunction+ , SetOfFunctionN+ , unsafeSetOfFunctionN+ ) where++import GHC.TypeLits++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Schema++{- |+A @RankNType@ for set returning functions with 1 argument.+-}+type SetOfFunction fun ty setof+ = forall outer commons schemas params+ . Expression outer commons 'Ungrouped schemas params '[] ty+ -- ^ input+ -> FromClause outer commons schemas params '[fun ::: setof]+ -- ^ output++-- | Escape hatch for a set returning function with 1 argument.+unsafeSetOfFunction+ :: forall fun ty setof. KnownSymbol fun+ => SetOfFunction fun ty setof -- ^ set returning function+unsafeSetOfFunction x = UnsafeFromClause $+ renderSymbol @fun <> parenthesized (renderSQL x)++{- |+A @RankNType@ for set returning functions with multiple argument.+-}+type SetOfFunctionN fun tys setof+ = forall outer commons schemas params+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys+ -- ^ inputs+ -> FromClause outer commons schemas params '[fun ::: setof]+ -- ^ output++-- | Escape hatch for a set returning function with multiple argument.+unsafeSetOfFunctionN+ :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)+ => SetOfFunctionN fun tys setof -- ^ set returning function+unsafeSetOfFunctionN xs = UnsafeFromClause $+ renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)++{- | @generateSeries (start *: stop)@++Generate a series of values, from @start@ to @stop@ with a step size of one+-}+generateSeries+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]+ => SetOfFunctionN "generate_series" '[ null ty, null ty]+ '["generate_series" ::: null ty] -- ^ set returning function+generateSeries = unsafeSetOfFunctionN++{- | @generateSeries (start :* stop *: step)@++Generate a series of values, from @start@ to @stop@ with a step size of @step@+-}+generateSeriesStep+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]+ => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]+ '["generate_series" ::: null ty] -- ^ set returning function+generateSeriesStep = unsafeSetOfFunctionN++{- | @generateSeries (start :* stop *: step)@++Generate a series of values, from @start@ to @stop@ with a step size of @step@+-}+generateSeriesTimestamp+ :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]+ => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]+ '["generate_series" ::: null ty] -- ^ set returning function+generateSeriesTimestamp = unsafeSetOfFunctionN
+ src/Squeal/PostgreSQL/Expression/Sort.hs view
@@ -0,0 +1,85 @@+{-|+Module: Squeal.PostgreSQL.Expression.Sort+Description: Sort expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Sort expressions+-}++{-# LANGUAGE+ DataKinds+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , StandaloneDeriving+#-}++module Squeal.PostgreSQL.Expression.Sort+ ( SortExpression (..)+ , OrderBy (..)+ ) where++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- | `SortExpression`s are used by `orderBy` to optionally sort the results+-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`+-- set the sort direction of a `NotNull` result+-- column to ascending or descending. Ascending order puts smaller values+-- first, where "smaller" is defined in terms of the+-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,+-- descending order is determined with the+-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to+-- determine whether nulls appear before or after non-null values in the sort+-- ordering of a `Null` result column.+data SortExpression outer commons grp schemas params from where+ Asc+ :: Expression outer commons grp schemas params from ('NotNull ty)+ -> SortExpression outer commons grp schemas params from+ Desc+ :: Expression outer commons grp schemas params from ('NotNull ty)+ -> SortExpression outer commons grp schemas params from+ AscNullsFirst+ :: Expression outer commons grp schemas params from ('Null ty)+ -> SortExpression outer commons grp schemas params from+ AscNullsLast+ :: Expression outer commons grp schemas params from ('Null ty)+ -> SortExpression outer commons grp schemas params from+ DescNullsFirst+ :: Expression outer commons grp schemas params from ('Null ty)+ -> SortExpression outer commons grp schemas params from+ DescNullsLast+ :: Expression outer commons grp schemas params from ('Null ty)+ -> SortExpression outer commons grp schemas params from+deriving instance Show (SortExpression outer commons grp schemas params from)+instance RenderSQL (SortExpression outer commons grp schemas params from) where+ renderSQL = \case+ Asc expression -> renderSQL expression <+> "ASC"+ Desc expression -> renderSQL expression <+> "DESC"+ AscNullsFirst expression -> renderSQL expression+ <+> "ASC NULLS FIRST"+ DescNullsFirst expression -> renderSQL expression+ <+> "DESC NULLS FIRST"+ AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"+ DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"++{- |+The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`+to be sorted according to the specified `SortExpression`(s).+If two rows are equal according to the leftmost expression,+they are compared according to the next expression and so on.+If they are equal according to all specified expressions,+they are returned in an implementation-dependent order.++You can also control the order in which rows are processed by window functions+using `orderBy` within `Squeal.PostgreSQL.Query.Over`.+-}+class OrderBy expr where+ orderBy+ :: [SortExpression outer commons grp schemas params from]+ -> expr outer commons grp schemas params from+ -> expr outer commons grp schemas params from
+ src/Squeal/PostgreSQL/Expression/Subquery.hs view
@@ -0,0 +1,120 @@+{-|+Module: Squeal.PostgreSQL.Expression.Subquery+Description: Subquery expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Subquery expressions+-}++{-# LANGUAGE+ DataKinds+ , OverloadedStrings+ , RankNTypes+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Subquery+ ( exists+ , in_+ , notIn+ , subAll+ , subAny+ ) where++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- |+The argument of `exists` is an arbitrary subquery. The subquery is evaluated+to determine whether it returns any rows. If it returns at least one row,+the result of `exists` is `true`; if the subquery returns no rows,+the result of `exists` is `false`.++The subquery can refer to variables from the surrounding query,+which will act as constants during any one evaluation of the subquery.++The subquery will generally only be executed long enough to determine whether+at least one row is returned, not all the way to completion.+-}+exists+ :: Query (Join outer from) commons schemas params row+ -> Condition outer commons grp schemas params from+exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)++{- |+The right-hand side is a parenthesized subquery, which must return+exactly one column. The left-hand expression is evaluated and compared to each+row of the subquery result using the given `Operator`,+which must yield a Boolean result. The result of `subAll` is `true`+if all rows yield true (including the case where the subquery returns no rows).+The result is `false` if any `false` result is found.+The result is `Squeal.PostgreSQL.Expression.Null.null_` if+ no comparison with a subquery row returns `false`,+and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.++>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))+(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))+-}+subAll+ :: Expression outer commons grp schemas params from ty1 -- ^ expression+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery+ -> Condition outer commons grp schemas params from+subAll expr (?) qry = expr ?+ (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))++{- |+The right-hand side is a parenthesized subquery, which must return exactly one column.+The left-hand expression is evaluated and compared to each row of the subquery result+using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`+if any `true` result is obtained. The result is `false` if no true result is found+(including the case where the subquery returns no rows).++>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))+(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))+-}+subAny+ :: Expression outer commons grp schemas params from ty1 -- ^ expression+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery+ -> Condition outer commons grp schemas params from+subAny expr (?) qry = expr ?+ (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))++{- |+The result is `true` if the left-hand expression's result is equal+to any of the right-hand expressions.++>>> printSQL $ true `in_` [true, false, null_]+TRUE IN (TRUE, FALSE, NULL)+-}+in_+ :: Expression outer commons grp schemas params from ty -- ^ expression+ -> [Expression outer commons grp schemas params from ty]+ -> Condition outer commons grp schemas params from+expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))++{- |+The result is `true` if the left-hand expression's result is not equal+to any of the right-hand expressions.++>>> printSQL $ true `notIn` [false, null_]+TRUE NOT IN (FALSE, NULL)+-}+notIn+ :: Expression outer commons grp schemas params from ty -- ^ expression+ -> [Expression outer commons grp schemas params from ty]+ -> Condition outer commons grp schemas params from+expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))
+ src/Squeal/PostgreSQL/Expression/Text.hs view
@@ -0,0 +1,64 @@+{-|+Module: Squeal.PostgreSQL.Expression.Text+Description: Text expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++String functions and operators+-}++{-# LANGUAGE+ DataKinds+ , OverloadedStrings+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Text+ ( lower+ , upper+ , charLength+ , like+ , ilike+ ) where++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | >>> printSQL $ lower "ARRRGGG"+-- lower(E'ARRRGGG')+lower :: null 'PGtext :--> null 'PGtext+lower = unsafeFunction "lower"++-- | >>> printSQL $ upper "eeee"+-- upper(E'eeee')+upper :: null 'PGtext :--> null 'PGtext+upper = unsafeFunction "upper"++-- | >>> printSQL $ charLength "four"+-- char_length(E'four')+charLength :: null 'PGtext :--> null 'PGint4+charLength = unsafeFunction "char_length"++-- | The `like` expression returns true if the @string@ matches+-- the supplied @pattern@. If @pattern@ does not contain percent signs+-- or underscores, then the pattern only represents the string itself;+-- in that case `like` acts like the equals operator. An underscore (_)+-- in pattern stands for (matches) any single character; a percent sign (%)+-- matches any sequence of zero or more characters.+--+-- >>> printSQL $ "abc" `like` "a%"+-- (E'abc' LIKE E'a%')+like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)+like = unsafeBinaryOp "LIKE"++-- | The key word ILIKE can be used instead of LIKE to make the+-- match case-insensitive according to the active locale.+--+-- >>> printSQL $ "abc" `ilike` "a%"+-- (E'abc' ILIKE E'a%')+ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)+ilike = unsafeBinaryOp "ILIKE"
+ src/Squeal/PostgreSQL/Expression/TextSearch.hs view
@@ -0,0 +1,158 @@+{-|+Module: Squeal.PostgreSQL.Expression.TextSearch+Description: Text search expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Text search functions and operators+-}++{-# LANGUAGE+ DataKinds+ , OverloadedStrings+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.TextSearch+ ( (@@)+ , (.&)+ , (.|)+ , (.!)+ , (<->)+ , arrayToTSvector+ , tsvectorLength+ , numnode+ , plainToTSquery+ , phraseToTSquery+ , websearchToTSquery+ , queryTree+ , toTSquery+ , toTSvector+ , setWeight+ , strip+ , jsonToTSvector+ , jsonbToTSvector+ , tsDelete+ , tsFilter+ , tsHeadline+ ) where++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Schema++-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?+(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)+(@@) = unsafeBinaryOp "@@"++-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together+(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)+(.&) = unsafeBinaryOp "&&"++-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together+(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)+(.|) = unsafeBinaryOp "||"++-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`+(.!) :: null 'PGtsquery :--> null 'PGtsquery+(.!) = unsafeUnaryOpL "!!"++-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by+-- `Squeal.PostgreSQL.Expression.Type.tsquery`+(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)+(<->) = unsafeBinaryOp "<->"++-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`+arrayToTSvector+ :: null ('PGvararray ('NotNull 'PGtext))+ :--> null 'PGtsvector+arrayToTSvector = unsafeFunction "array_to_tsvector"++-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`+tsvectorLength :: null 'PGtsvector :--> null 'PGint4+tsvectorLength = unsafeFunction "length"++-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`+numnode :: null 'PGtsquery :--> null 'PGint4+numnode = unsafeFunction "numnode"++-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation+plainToTSquery :: null 'PGtext :--> null 'PGtsquery+plainToTSquery = unsafeFunction "plainto_tsquery"++-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,+-- ignoring punctuation+phraseToTSquery :: null 'PGtext :--> null 'PGtsquery+phraseToTSquery = unsafeFunction "phraseto_tsquery"++-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query+websearchToTSquery :: null 'PGtext :--> null 'PGtsquery+websearchToTSquery = unsafeFunction "websearch_to_tsquery"++-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`+queryTree :: null 'PGtsquery :--> null 'PGtext+queryTree = unsafeFunction "query_tree"++-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`+toTSquery :: null 'PGtext :--> null 'PGtsquery+toTSquery = unsafeFunction "to_tsquery"++-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`+toTSvector+ :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]+ => null ty :--> null 'PGtsvector+toTSvector = unsafeFunction "to_tsvector"++-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`+setWeight+ :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)+setWeight = unsafeFunctionN "set_weight"++-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`+strip :: null 'PGtsvector :--> null 'PGtsvector+strip = unsafeFunction "strip"++-- | @jsonToTSvector (document *: filter)@+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.+-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.+-- Possible values for filter are "string" (to include all string values),+-- "numeric" (to include all numeric values in the string format),+-- "boolean" (to include all Boolean values in the string format "true"/"false"),+-- "key" (to include all keys) or "all" (to include all above).+-- These values can be combined together to include, e.g. all string and numeric values.+jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)+jsonToTSvector = unsafeFunctionN "json_to_tsvector"++-- | @jsonbToTSvector (document *: filter)@+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.+-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.+-- Possible values for filter are "string" (to include all string values),+-- "numeric" (to include all numeric values in the string format),+-- "boolean" (to include all Boolean values in the string format "true"/"false"),+-- "key" (to include all keys) or "all" (to include all above).+-- These values can be combined together to include, e.g. all string and numeric values.+jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)+jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"++-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`+tsDelete :: FunctionN+ '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]+ (null 'PGtsvector)+tsDelete = unsafeFunctionN "ts_delete"++-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`+tsFilter :: FunctionN+ '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]+ (null 'PGtsvector)+tsFilter = unsafeFunctionN "ts_filter"++-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match+tsHeadline+ :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]+ => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)+tsHeadline = unsafeFunctionN "ts_headline"
+ src/Squeal/PostgreSQL/Expression/Time.hs view
@@ -0,0 +1,197 @@+{-|+Module: Squeal.PostgreSQL.Expression.Time+Description: Date/Time expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Date/Time functions and operators+-}++{-# LANGUAGE+ DataKinds+ , DeriveGeneric+ , FunctionalDependencies+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+#-}++module Squeal.PostgreSQL.Expression.Time+ ( TimeOp (..)+ , currentDate+ , currentTime+ , currentTimestamp+ , localTime+ , localTimestamp+ , now+ , makeDate+ , makeTime+ , makeTimestamp+ , makeTimestamptz+ , interval_+ , TimeUnit (..)+ ) where++import Data.String++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | >>> printSQL currentDate+-- CURRENT_DATE+currentDate :: Expr (null 'PGdate)+currentDate = UnsafeExpression "CURRENT_DATE"++-- | >>> printSQL currentTime+-- CURRENT_TIME+currentTime :: Expr (null 'PGtimetz)+currentTime = UnsafeExpression "CURRENT_TIME"++-- | >>> printSQL currentTimestamp+-- CURRENT_TIMESTAMP+currentTimestamp :: Expr (null 'PGtimestamptz)+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"++-- | >>> printSQL localTime+-- LOCALTIME+localTime :: Expr (null 'PGtime)+localTime = UnsafeExpression "LOCALTIME"++-- | >>> printSQL localTimestamp+-- LOCALTIMESTAMP+localTimestamp :: Expr (null 'PGtimestamp)+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"++-- | Current date and time (equivalent to `currentTimestamp`)+--+-- >>> printSQL now+-- now()+now :: Expr (null 'PGtimestamptz)+now = UnsafeExpression "now()"++{-|+Create date from year, month and day fields++>>> printSQL (makeDate (1984 :* 7 *: 3))+make_date(1984, 7, 3)+-}+makeDate :: FunctionN+ '[ null 'PGint4, null 'PGint4, null 'PGint4 ]+ ( null 'PGdate )+makeDate = unsafeFunctionN "make_date"++{-|+Create time from hour, minute and seconds fields++>>> printSQL (makeTime (8 :* 15 *: 23.5))+make_time(8, 15, 23.5)+-}+makeTime :: FunctionN+ '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]+ ( null 'PGtime )+makeTime = unsafeFunctionN "make_time"++{-|+Create timestamp from year, month, day, hour, minute and seconds fields++>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))+make_timestamp(2013, 7, 15, 8, 15, 23.5)+-}+makeTimestamp :: FunctionN+ '[ null 'PGint4, null 'PGint4, null 'PGint4+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]+ ( null 'PGtimestamp )+makeTimestamp = unsafeFunctionN "make_timestamp"++{-|+Create timestamp with time zone from+year, month, day, hour, minute and seconds fields;+the current time zone is used++>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))+make_timestamptz(2013, 7, 15, 8, 15, 23.5)+-}+makeTimestamptz :: FunctionN+ '[ null 'PGint4, null 'PGint4, null 'PGint4+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]+ ( null 'PGtimestamptz )+makeTimestamptz = unsafeFunctionN "make_timestamptz"++{-|+Affine space operations on time types.+-}+class TimeOp time diff | time -> diff where+ {-|+ >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)+ (make_date(1984, 7, 3) + 365)+ -}+ (!+) :: Operator (null time) (null diff) (null time)+ (!+) = unsafeBinaryOp "+"+ {-|+ >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))+ (365 + make_date(1984, 7, 3))+ -}+ (+!) :: Operator (null diff) (null time) (null time)+ (+!) = unsafeBinaryOp "+"+ {-|+ >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)+ (make_date(1984, 7, 3) - 365)+ -}+ (!-) :: Operator (null time) (null diff) (null time)+ (!-) = unsafeBinaryOp "-"+ {-|+ >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)+ (make_date(1984, 7, 3) - CURRENT_DATE)+ -}+ (!-!) :: Operator (null time) (null time) (null diff)+ (!-!) = unsafeBinaryOp "-"+instance TimeOp 'PGtimestamp 'PGinterval+instance TimeOp 'PGtimestamptz 'PGinterval+instance TimeOp 'PGtime 'PGinterval+instance TimeOp 'PGtimetz 'PGinterval+instance TimeOp 'PGinterval 'PGinterval+instance TimeOp 'PGdate 'PGint4+infixl 6 !++infixl 6 +!+infixl 6 !-+infixl 6 !-!++-- | A `TimeUnit` to use in `interval_` construction.+data TimeUnit+ = Years | Months | Weeks | Days+ | Hours | Minutes | Seconds+ | Microseconds | Milliseconds+ | Decades | Centuries | Millennia+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance SOP.Generic TimeUnit+instance SOP.HasDatatypeInfo TimeUnit+instance RenderSQL TimeUnit where+ renderSQL = \case+ Years -> "years"+ Months -> "months"+ Weeks -> "weeks"+ Days -> "days"+ Hours -> "hours"+ Minutes -> "minutes"+ Seconds -> "seconds"+ Microseconds -> "microseconds"+ Milliseconds -> "milliseconds"+ Decades -> "decades"+ Centuries -> "centuries"+ Millennia -> "millennia"++-- | >>> printSQL $ interval_ 7 Days+-- (INTERVAL '7.0 days')+interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)+interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>+ "'" <> fromString (show num) <+> renderSQL unit <> "'"
+ src/Squeal/PostgreSQL/Expression/Type.hs view
@@ -0,0 +1,295 @@+{-|+Module: Squeal.PostgreSQL.Expression+Description: Type expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Type expressions.+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , KindSignatures+ , MultiParamTypeClasses+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Type+ ( TypeExpression (..)+ , cast+ , astype+ , PGTyped (..)+ , typedef+ , typetable+ , typeview+ , bool+ , int2+ , smallint+ , int4+ , int+ , integer+ , int8+ , bigint+ , numeric+ , float4+ , real+ , float8+ , doublePrecision+ , money+ , text+ , char+ , character+ , varchar+ , characterVarying+ , bytea+ , timestamp+ , timestampWithTimeZone+ , date+ , time+ , timeWithTimeZone+ , interval+ , uuid+ , inet+ , json+ , jsonb+ , vararray+ , fixarray+ , tsvector+ , tsquery+ ) where++import Control.DeepSeq+import Data.ByteString+import Data.String+import GHC.TypeLits++import qualified Data.ByteString as ByteString+import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- When a `cast` is applied to an `Expression` of a known type, it+-- represents a run-time type conversion. The cast will succeed only if a+-- suitable type conversion operation has been defined.+--+-- | >>> printSQL $ true & cast int4+-- (TRUE :: int4)+cast+ :: TypeExpression schemas ty1+ -- ^ type to cast as+ -> Expression outer commons grp schemas params from ty0+ -- ^ value to convert+ -> Expression outer commons grp schemas params from ty1+cast ty x = UnsafeExpression $ parenthesized $+ renderSQL x <+> "::" <+> renderSQL ty++-- | A safe version of `cast` which just matches a value with its type.+--+-- >>> printSQL (1 & astype int)+-- (1 :: int)+astype+ :: TypeExpression schemas ty+ -- ^ type to specify as+ -> Expression outer commons grp schemas params from ty+ -- ^ value+ -> Expression outer commons grp schemas params from ty+astype = cast++{-----------------------------------------+type expressions+-----------------------------------------}++-- | `TypeExpression`s are used in `cast`s and+-- `Squeal.PostgreSQL.Definition.createTable` commands.+newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL (TypeExpression schemas ty) where+ renderSQL = renderTypeExpression++-- | The enum or composite type in a `Typedef` can be expressed by its alias.+typedef+ :: (Has sch schemas schema, Has td schema ('Typedef ty))+ => QualifiedAlias sch td+ -> TypeExpression schemas (null ty)+typedef = UnsafeTypeExpression . renderSQL++-- | The composite type corresponding to a `Table` definition can be expressed+-- by its alias.+typetable+ :: (Has sch schemas schema, Has tab schema ('Table table))+ => QualifiedAlias sch tab+ -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))+typetable = UnsafeTypeExpression . renderSQL++-- | The composite type corresponding to a `View` definition can be expressed+-- by its alias.+typeview+ :: (Has sch schemas schema, Has vw schema ('View view))+ => QualifiedAlias sch vw+ -> TypeExpression schemas (null ('PGcomposite view))+typeview = UnsafeTypeExpression . renderSQL++-- | logical Boolean (true/false)+bool :: TypeExpression schemas (null 'PGbool)+bool = UnsafeTypeExpression "bool"+-- | signed two-byte integer+int2, smallint :: TypeExpression schemas (null 'PGint2)+int2 = UnsafeTypeExpression "int2"+smallint = UnsafeTypeExpression "smallint"+-- | signed four-byte integer+int4, int, integer :: TypeExpression schemas (null 'PGint4)+int4 = UnsafeTypeExpression "int4"+int = UnsafeTypeExpression "int"+integer = UnsafeTypeExpression "integer"+-- | signed eight-byte integer+int8, bigint :: TypeExpression schemas (null 'PGint8)+int8 = UnsafeTypeExpression "int8"+bigint = UnsafeTypeExpression "bigint"+-- | arbitrary precision numeric type+numeric :: TypeExpression schemas (null 'PGnumeric)+numeric = UnsafeTypeExpression "numeric"+-- | single precision floating-point number (4 bytes)+float4, real :: TypeExpression schemas (null 'PGfloat4)+float4 = UnsafeTypeExpression "float4"+real = UnsafeTypeExpression "real"+-- | double precision floating-point number (8 bytes)+float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)+float8 = UnsafeTypeExpression "float8"+doublePrecision = UnsafeTypeExpression "double precision"+-- | currency amount+money :: TypeExpression schema (null 'PGmoney)+money = UnsafeTypeExpression "money"+-- | variable-length character string+text :: TypeExpression schemas (null 'PGtext)+text = UnsafeTypeExpression "text"+-- | fixed-length character string+char, character+ :: forall n schemas null. (KnownNat n, 1 <= n)+ => TypeExpression schemas (null ('PGchar n))+char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"+character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"+-- | variable-length character string+varchar, characterVarying+ :: forall n schemas null. (KnownNat n, 1 <= n)+ => TypeExpression schemas (null ('PGvarchar n))+varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"+characterVarying = UnsafeTypeExpression $+ "character varying(" <> renderNat @n <> ")"+-- | binary data ("byte array")+bytea :: TypeExpression schemas (null 'PGbytea)+bytea = UnsafeTypeExpression "bytea"+-- | date and time (no time zone)+timestamp :: TypeExpression schemas (null 'PGtimestamp)+timestamp = UnsafeTypeExpression "timestamp"+-- | date and time, including time zone+timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"+-- | calendar date (year, month, day)+date :: TypeExpression schemas (null 'PGdate)+date = UnsafeTypeExpression "date"+-- | time of day (no time zone)+time :: TypeExpression schemas (null 'PGtime)+time = UnsafeTypeExpression "time"+-- | time of day, including time zone+timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)+timeWithTimeZone = UnsafeTypeExpression "time with time zone"+-- | time span+interval :: TypeExpression schemas (null 'PGinterval)+interval = UnsafeTypeExpression "interval"+-- | universally unique identifier+uuid :: TypeExpression schemas (null 'PGuuid)+uuid = UnsafeTypeExpression "uuid"+-- | IPv4 or IPv6 host address+inet :: TypeExpression schemas (null 'PGinet)+inet = UnsafeTypeExpression "inet"+-- | textual JSON data+json :: TypeExpression schemas (null 'PGjson)+json = UnsafeTypeExpression "json"+-- | binary JSON data, decomposed+jsonb :: TypeExpression schemas (null 'PGjsonb)+jsonb = UnsafeTypeExpression "jsonb"+-- | variable length array+vararray+ :: TypeExpression schemas pg+ -> TypeExpression schemas (null ('PGvararray pg))+vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"+-- | fixed length array+--+-- >>> renderSQL (fixarray @'[2] json)+-- "json[2]"+fixarray+ :: forall dims schemas null pg. SOP.All KnownNat dims+ => TypeExpression schemas pg+ -> TypeExpression schemas (null ('PGfixarray dims pg))+fixarray ty = UnsafeTypeExpression $+ renderSQL ty <> renderDims @dims+ where+ renderDims :: forall ns. SOP.All KnownNat ns => ByteString+ renderDims =+ ("[" <>)+ . (<> "]")+ . ByteString.intercalate "]["+ . SOP.hcollapse+ $ SOP.hcmap (SOP.Proxy @KnownNat)+ (K . fromString . show . natVal)+ (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)+-- | text search query+tsvector :: TypeExpression schemas (null 'PGtsvector)+tsvector = UnsafeTypeExpression "tsvector"+-- | text search document+tsquery :: TypeExpression schemas (null 'PGtsquery)+tsquery = UnsafeTypeExpression "tsquery"++-- | `pgtype` is a demoted version of a `PGType`+class PGTyped schemas (ty :: NullityType) where+ pgtype :: TypeExpression schemas ty+instance PGTyped schemas (null 'PGbool) where pgtype = bool+instance PGTyped schemas (null 'PGint2) where pgtype = int2+instance PGTyped schemas (null 'PGint4) where pgtype = int4+instance PGTyped schemas (null 'PGint8) where pgtype = int8+instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric+instance PGTyped schemas (null 'PGfloat4) where pgtype = float4+instance PGTyped schemas (null 'PGfloat8) where pgtype = float8+instance PGTyped schemas (null 'PGmoney) where pgtype = money+instance PGTyped schemas (null 'PGtext) where pgtype = text+instance (KnownNat n, 1 <= n)+ => PGTyped schemas (null ('PGchar n)) where pgtype = char @n+instance (KnownNat n, 1 <= n)+ => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n+instance PGTyped schemas (null 'PGbytea) where pgtype = bytea+instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp+instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone+instance PGTyped schemas (null 'PGdate) where pgtype = date+instance PGTyped schemas (null 'PGtime) where pgtype = time+instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone+instance PGTyped schemas (null 'PGinterval) where pgtype = interval+instance PGTyped schemas (null 'PGuuid) where pgtype = uuid+instance PGTyped schemas (null 'PGjson) where pgtype = json+instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb+instance PGTyped schemas ty+ => PGTyped schemas (null ('PGvararray ty)) where+ pgtype = vararray (pgtype @schemas @ty)+instance (SOP.All KnownNat dims, PGTyped schemas ty)+ => PGTyped schemas (null ('PGfixarray dims ty)) where+ pgtype = fixarray @dims (pgtype @schemas @ty)+instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector+instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
+ src/Squeal/PostgreSQL/Expression/Window.hs view
@@ -0,0 +1,284 @@+{-|+Module: Squeal.PostgreSQL.Expression.Window+Description: Window functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Window functions and definitions+-}++{-# LANGUAGE+ DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , RankNTypes+ , KindSignatures+#-}++module Squeal.PostgreSQL.Expression.Window+ ( -- * functions+ partitionBy+ , rank+ , rowNumber+ , denseRank+ , percentRank+ , cumeDist+ , ntile+ , lag+ , lead+ , firstValue+ , lastValue+ , nthValue+ , unsafeWindowFunction1+ , unsafeWindowFunctionN+ -- * types+ , WindowFunction (..)+ , WindowDefinition (..)+ , WinFun0+ , WinFun1+ , WinFunN+ ) where++import Control.DeepSeq+import Data.ByteString++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Aggregate+import Squeal.PostgreSQL.Expression.Sort+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++instance Aggregate+ (Expression outer commons grp schemas params from)+ (NP (Expression outer commons grp schemas params from))+ (WindowFunction outer commons grp schemas params from) where+ countStar = UnsafeWindowFunction "count(*)"+ count = unsafeWindowFunction1 "count"+ sum_ = unsafeWindowFunction1 "sum"+ arrayAgg = unsafeWindowFunction1 "array_agg"+ jsonAgg = unsafeWindowFunction1 "json_agg"+ jsonbAgg = unsafeWindowFunction1 "jsonb_agg"+ bitAnd = unsafeWindowFunction1 "bit_and"+ bitOr = unsafeWindowFunction1 "bit_or"+ boolAnd = unsafeWindowFunction1 "bool_and"+ boolOr = unsafeWindowFunction1 "bool_or"+ every = unsafeWindowFunction1 "every"+ max_ = unsafeWindowFunction1 "max"+ min_ = unsafeWindowFunction1 "min"+ avg = unsafeWindowFunction1 "avg"+ corr = unsafeWindowFunctionN "corr"+ covarPop = unsafeWindowFunctionN "covar_pop"+ covarSamp = unsafeWindowFunctionN "covar_samp"+ regrAvgX = unsafeWindowFunctionN "regr_avgx"+ regrAvgY = unsafeWindowFunctionN "regr_avgy"+ regrCount = unsafeWindowFunctionN "regr_count"+ regrIntercept = unsafeWindowFunctionN "regr_intercept"+ regrR2 = unsafeWindowFunctionN "regr_r2"+ regrSlope = unsafeWindowFunctionN "regr_slope"+ regrSxx = unsafeWindowFunctionN "regr_sxx"+ regrSxy = unsafeWindowFunctionN "regr_sxy"+ regrSyy = unsafeWindowFunctionN "regr_syy"+ stddev = unsafeWindowFunction1 "stddev"+ stddevPop = unsafeWindowFunction1 "stddev_pop"+ stddevSamp = unsafeWindowFunction1 "stddev_samp"+ variance = unsafeWindowFunction1 "variance"+ varPop = unsafeWindowFunction1 "var_pop"+ varSamp = unsafeWindowFunction1 "var_samp"++-- | A `WindowDefinition` is a set of table rows that are somehow related+-- to the current row+data WindowDefinition outer commons grp schemas params from where+ WindowDefinition+ :: SOP.SListI bys+ => NP (Expression outer commons grp schemas params from) bys+ -- ^ `partitionBy` clause+ -> [SortExpression outer commons grp schemas params from]+ -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause+ -> WindowDefinition outer commons grp schemas params from++instance OrderBy WindowDefinition where+ orderBy sortsR (WindowDefinition parts sortsL)+ = WindowDefinition parts (sortsL ++ sortsR)++instance RenderSQL (WindowDefinition outer commons schemas from grp params) where+ renderSQL (WindowDefinition part ord) =+ renderPartitionByClause part <> renderOrderByClause ord+ where+ renderPartitionByClause = \case+ Nil -> ""+ parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts+ renderOrderByClause = \case+ [] -> ""+ srts -> " ORDER" <+> "BY"+ <+> commaSeparated (renderSQL <$> srts)++{- |+The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,+or partitions, that share the same values of the `partitionBy` `Expression`(s).+For each row, the window function is computed across the rows that fall into+the same partition as the current row.+-}+partitionBy+ :: SOP.SListI bys+ => NP (Expression outer commons grp schemas params from) bys -- ^ partitions+ -> WindowDefinition outer commons grp schemas params from+partitionBy bys = WindowDefinition bys []++{- |+A window function performs a calculation across a set of table rows+that are somehow related to the current row. This is comparable to the type+of calculation that can be done with an aggregate function.+However, window functions do not cause rows to become grouped into a single+output row like non-window aggregate calls would.+Instead, the rows retain their separate identities.+Behind the scenes, the window function is able to access more than+just the current row of the query result.+-}+newtype WindowFunction+ (outer :: FromType)+ (commons :: FromType)+ (grp :: Grouping)+ (schemas :: SchemasType)+ (params :: [NullityType])+ (from :: FromType)+ (ty :: NullityType)+ = UnsafeWindowFunction { renderWindowFunction :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where+ renderSQL = renderWindowFunction++{- |+A @RankNType@ for window functions with no arguments.+-}+type WinFun0 x+ = forall outer commons grp schemas params from+ . WindowFunction outer commons grp schemas params from x+ -- ^ cannot reference aliases++{- |+A @RankNType@ for window functions with 1 argument.+-}+type WinFun1 x y+ = forall outer commons grp schemas params from+ . Expression outer commons grp schemas params from x+ -- ^ input+ -> WindowFunction outer commons grp schemas params from y+ -- ^ output++{- | A @RankNType@ for window functions with a fixed-length+list of heterogeneous arguments.+Use the `*:` operator to end your argument lists.+-}+type WinFunN xs y+ = forall outer commons grp schemas params from+ . NP (Expression outer commons grp schemas params from) xs+ -- ^ inputs+ -> WindowFunction outer commons grp schemas params from y+ -- ^ output++-- | escape hatch for defining window functions+unsafeWindowFunction1 :: ByteString -> WinFun1 x y+unsafeWindowFunction1 fun x+ = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)++-- | escape hatch for defining multi-argument window functions+unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y+unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>+ parenthesized (renderCommaSeparated renderSQL xs)++{- | rank of the current row with gaps; same as `rowNumber` of its first peer++>>> printSQL rank+rank()+-}+rank :: WinFun0 ('NotNull 'PGint8)+rank = UnsafeWindowFunction "rank()"++{- | number of the current row within its partition, counting from 1++>>> printSQL rowNumber+row_number()+-}+rowNumber :: WinFun0 ('NotNull 'PGint8)+rowNumber = UnsafeWindowFunction "row_number()"++{- | rank of the current row without gaps; this function counts peer groups++>>> printSQL denseRank+dense_rank()+-}+denseRank :: WinFun0 ('NotNull 'PGint8)+denseRank = UnsafeWindowFunction "dense_rank()"++{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)++>>> printSQL percentRank+percent_rank()+-}+percentRank :: WinFun0 ('NotNull 'PGfloat8)+percentRank = UnsafeWindowFunction "percent_rank()"++{- | cumulative distribution: (number of partition rows+preceding or peer with current row) / total partition rows++>>> printSQL cumeDist+cume_dist()+-}+cumeDist :: WinFun0 ('NotNull 'PGfloat8)+cumeDist = UnsafeWindowFunction "cume_dist()"++{- | integer ranging from 1 to the argument value,+dividing the partition as equally as possible++>>> printSQL $ ntile 5+ntile(5)+-}+ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)+ntile = unsafeWindowFunction1 "ntile"++{- | returns value evaluated at the row that is offset rows before the current+row within the partition; if there is no such row, instead return default+(which must be of the same type as value). Both offset and default are+evaluated with respect to the current row.+-}+lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty+lag = unsafeWindowFunctionN "lag"++{- | returns value evaluated at the row that is offset rows after the current+row within the partition; if there is no such row, instead return default+(which must be of the same type as value). Both offset and default are+evaluated with respect to the current row.+-}+lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty+lead = unsafeWindowFunctionN "lead"++{- | returns value evaluated at the row that is the+first row of the window frame+-}+firstValue :: WinFun1 ty ty+firstValue = unsafeWindowFunction1 "first_value"++{- | returns value evaluated at the row that is the+last row of the window frame+-}+lastValue :: WinFun1 ty ty+lastValue = unsafeWindowFunction1 "last_value"++{- | returns value evaluated at the row that is the nth+row of the window frame (counting from 1); null if no such row+-}+nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)+nthValue = unsafeWindowFunctionN "nth_value"
+ src/Squeal/PostgreSQL/List.hs view
@@ -0,0 +1,141 @@+{-|+Module: Squeal.PostgreSQL.List+Description: List related types and functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Haskell singly-linked lists are very powerful. This module+provides functionality for type-level lists, heterogeneous+lists and type aligned lists.+-}++{-# LANGUAGE+ DataKinds+ , FlexibleContexts+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.List+ ( SOP.NP (..)+ , (*:)+ , Join+ , disjoin+ , Additional (..)+ , AlignedList (..)+ , single+ , extractList+ , mapAligned+ , Elem+ , In+ , Length+ ) where++import Control.Category+import Data.Function ((&))+import Data.Kind+import Data.Type.Bool+import GHC.TypeLits++import Generics.SOP as SOP++import Squeal.PostgreSQL.Render++-- | `Join` is simply promoted `++` and is used in @JOIN@s in+-- `Squeal.PostgreSQL.Query.FromClause`s.+type family Join xs ys where+ Join '[] ys = ys+ Join (x ': xs) ys = x ': Join xs ys++-- | `disjoin` is a utility function for splitting an `NP` list into pieces.+disjoin+ :: forall xs ys expr. SListI xs+ => NP expr (Join xs ys)+ -> (NP expr xs, NP expr ys)+disjoin = case sList @xs of+ SNil -> \ys -> (Nil, ys)+ SCons -> \(x :* xsys) ->+ case disjoin xsys of (xs,ys) -> (x :* xs, ys)++-- | The `Additional` class is for appending+-- type-level list parameterized constructors such as `NP`,+-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.+class Additional expr where+ also :: expr ys -> expr xs -> expr (Join xs ys)+instance Additional (NP expr) where+ also ys = \case+ Nil -> ys+ x :* xs -> x :* (xs & also ys)++-- | An `AlignedList` is a type-aligned list or free category.+data AlignedList p x0 x1 where+ Done :: AlignedList p x x+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2+infixr 7 :>>+instance Category (AlignedList p) where+ id = Done+ (.) list = \case+ Done -> list+ step :>> steps -> step :>> (steps >>> list)+instance (forall t0 t1. RenderSQL (p t0 t1))+ => RenderSQL (AlignedList p x0 x1) where+ renderSQL = \case+ Done -> ""+ step :>> Done -> renderSQL step+ step :>> steps -> renderSQL step <> ", " <> renderSQL steps++-- | `extractList` turns an `AlignedList` into a standard list.+extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]+extractList f = \case+ Done -> []+ step :>> steps -> (f step):extractList f steps++-- | `mapAligned` applies a function to each element of an `AlignedList`.+mapAligned+ :: (forall z0 z1. p z0 z1 -> q z0 z1)+ -> AlignedList p x0 x1+ -> AlignedList q x0 x1+mapAligned f = \case+ Done -> Done+ x :>> xs -> f x :>> mapAligned f xs++-- | A `single` step.+single :: p x0 x1 -> AlignedList p x0 x1+single step = step :>> Done++-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.+(*:) :: f x -> f y -> NP f '[x,y]+x *: y = x :* y :* Nil+infixl 9 *:++-- | @Elem@ is a promoted `Data.List.elem`.+type family Elem x xs where+ Elem x '[] = 'False+ Elem x (x ': xs) = 'True+ Elem x (_ ': xs) = Elem x xs++-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.+type family In x xs :: Constraint where+ In x xs = If (Elem x xs) (() :: Constraint)+ (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))++{- | Calculate the `Length` of a type level list++>>> :kind! Length '[Char,String,Bool,Double]+Length '[Char,String,Bool,Double] :: Nat+= 4+-}+type family Length (xs :: [k]) :: Nat where+ Length (x : xs) = 1 + Length xs+ Length '[] = 0
src/Squeal/PostgreSQL/Manipulation.hs view
@@ -11,81 +11,140 @@ {-# LANGUAGE DeriveGeneric , FlexibleContexts+ , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving , LambdaCase+ , MultiParamTypeClasses , OverloadedStrings+ , PatternSynonyms+ , QuantifiedConstraints , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies , TypeInType , TypeOperators+ , UndecidableInstances #-} module Squeal.PostgreSQL.Manipulation ( -- * Manipulation- Manipulation (UnsafeManipulation, renderManipulation)+ Manipulation_+ , Manipulation (..) , queryStatement- , ColumnValue (..)- , ReturningClause (ReturningStar, Returning)- , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate) -- * Insert- , insertRows- , insertRow- , insertRows_- , insertRow_- , insertQuery- , insertQuery_- , renderReturningClause- , renderConflictClause+ , insertInto+ , insertInto_ -- * Update , update , update_ -- * Delete , deleteFrom , deleteFrom_+ -- * Clauses+ , Optional (..)+ , QueryClause (..)+ , pattern Values_+ , ReturningClause (..)+ , pattern Returning_+ , ConflictClause (..)+ , ConflictTarget (..)+ , ConflictAction (..)+ , UsingClause (..) ) where import Control.DeepSeq import Data.ByteString hiding (foldr)+import Data.Kind (Type) import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC +import Squeal.PostgreSQL.Alias import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.PG import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Schema +-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> import Data.Int+-- >>> import Data.Time+ {- | A `Manipulation` is a statement which may modify data in the database,-but does not alter the schema. Examples are inserts, updates and deletes.+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. +The general `Manipulation` type is parameterized by++* @commons :: FromType@ - scope for all `common` table expressions,+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,+* @row :: RowType@ - return type of the `Query`.+-}+newtype Manipulation+ (commons :: FromType)+ (schemas :: SchemasType)+ (params :: [NullityType])+ (columns :: RowType)+ = UnsafeManipulation { renderManipulation :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL (Manipulation commons schemas params columns) where+ renderSQL = renderManipulation+instance With Manipulation where+ with Done manip = manip+ with ctes manip = UnsafeManipulation $+ "WITH" <+> renderSQL ctes <+> renderSQL manip++{- |+The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,+against which the query is type-checked, an input @parameters@ Haskell `Type`,+and an ouput row Haskell `Type`.++A top-level `Manipulation_` can be run+using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@+using `Squeal.PostgreSQL.PQ.manipulate`.++Generally, @parameters@ 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 or a generalized record using tuples of `P` types and normal Haskell+records, whose entries will be targeted using overloaded labels.++>>> :set -XDeriveAnyClass -XDerivingStrategies+>>> :{+data Row a b = Row { col1 :: a, col2 :: b }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}+ simple insert: +>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[]+ manipulation :: Manipulation_ (Public Schema) () () manipulation =- insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2)) in printSQL manipulation :} INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) parameterized insert: +>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]- '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) () manipulation =- insertRow_ #tab- (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2)+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2)) in printSQL manipulation :} INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))@@ -94,71 +153,48 @@ >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[]- '["fromOnly" ::: 'NotNull 'PGint4]+ manipulation :: Manipulation_ (Public Schema) () (Only Int32) manipulation =- insertRow #tab (Set 2 `as` #col1 :* Default `as` #col2)+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2)) OnConflictDoRaise (Returning (#col1 `as` #fromOnly)) in printSQL manipulation :}-INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) RETURNING "col1" AS "fromOnly"+INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly" upsert: +>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]+>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]+>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]- '[] '[ "sum" ::: 'NotNull 'PGint4]+ manipulation :: Manipulation_ (Public CustomersSchema) () () manipulation =- insertRows #tab- (Set 2 `as` #col1 :* Set 4 `as` #col2)- [Set 6 `as` #col1 :* Set 8 `as` #col2]- (OnConflictDoUpdate- (Set 2 `as` #col1 :* Same `as` #col2)- [#col1 .== #col2])- (Returning $ (#col1 + #col2) `as` #sum)+ 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 :}-INSERT INTO "tab" ("col1", "col2") VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET "col1" = 2 WHERE ("col1" = "col2") RETURNING ("col1" + "col2") AS "sum"+INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email")) query insert: >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4- ])- , "other_tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4- ])- ] '[] '[]- manipulation =- insertQuery_ #tab- (selectStar (from (table (#other_tab `as` #t))))+ manipulation :: Manipulation_ (Public Schema) () ()+ manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab)))) in printSQL manipulation :}-INSERT INTO "tab" SELECT * FROM "other_tab" AS "t"+INSERT INTO "tab" SELECT * FROM "tab" AS "tab" update: >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]- manipulation =- update_ #tab (Set 2 `as` #col1 :* Same `as` #col2)- (#col1 ./= #col2)+ manipulation :: Manipulation_ (Public Schema) () ()+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2) in printSQL manipulation :} UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")@@ -167,179 +203,169 @@ >>> :{ let- manipulation :: Manipulation- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[]- '[ "col1" ::: 'NotNull 'PGint4- , "col2" ::: 'NotNull 'PGint4 ]- manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)+ manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star) in printSQL manipulation :} DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING * -with manipulation:+delete and using clause: ->>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]+>>> :{+type Schema3 =+ '[ "tab" ::: 'Table ('[] :=> Columns)+ , "other_tab" ::: 'Table ('[] :=> Columns)+ , "third_tab" ::: 'Table ('[] :=> Columns) ]+:} >>> :{ let- manipulation :: Manipulation- '[ "products" ::: 'Table ProductsTable- , "products_deleted" ::: 'Table ProductsTable- ] '[ 'NotNull 'PGdate] '[]+ manipulation :: Manipulation_ (Public Schema3) () ()+ manipulation =+ 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+:}+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"))++with manipulation:++>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]+>>> :{+let+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) () manipulation = with- (deleteFrom #products (#date .< param @1) ReturningStar `as` #deleted_rows)- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `as` #t)))))+ (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)+ (insertInto_ #products_deleted (Subquery (select Star (from (common #del))))) in printSQL manipulation :}-WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t"+WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del" -}--newtype Manipulation- (schema :: SchemaType)- (params :: [NullityType])- (columns :: RowType)- = UnsafeManipulation { renderManipulation :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (Manipulation schema params columns) where- renderSQL = renderManipulation-instance With Manipulation where- with Done manip = manip- with (cte :>> ctes) manip = UnsafeManipulation $- "WITH" <+> renderCommonTableExpressions renderManipulation cte ctes- <+> renderManipulation manip+type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where+ Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row) -- | Convert a `Query` into a `Manipulation`. queryStatement- :: Query schema params columns- -> Manipulation schema params columns-queryStatement q = UnsafeManipulation $ renderQuery q+ :: Query '[] commons schemas params columns+ -> Manipulation commons schemas params columns+queryStatement q = UnsafeManipulation $ renderSQL q {----------------------------------------- INSERT statements -----------------------------------------} --- | Insert multiple rows.------ When a table is created, it contains no data. The first thing to do--- before a database can be of much use is to insert data. Data is--- 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.-insertRows- :: ( SOP.SListI columns- , SOP.SListI results+{- |+When a table is created, it contains no data. The first thing to do+before a database can be of much use is to insert data. Data is+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.+-}+insertInto+ :: ( Has sch schemas schema , Has tab schema ('Table table)- , row ~ TableToRow table- , columns ~ TableToColumns table )- => Alias tab -- ^ table to insert into- -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert- -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert- -> ConflictClause schema table params- -- ^ what to do in case of constraint conflict- -> ReturningClause schema params row results -- ^ results to return- -> Manipulation schema params results-insertRows tab rw rws conflict returning = UnsafeManipulation $- "INSERT" <+> "INTO" <+> renderAlias tab- <+> parenthesized (renderCommaSeparated renderAliasPart rw)- <+> "VALUES"- <+> commaSeparated- ( parenthesized- . renderCommaSeparated renderColumnValuePart <$> rw:rws )- <> renderConflictClause conflict- <> renderReturningClause returning- where- renderAliasPart, renderColumnValuePart- :: Aliased (ColumnValue schema '[] params) ty -> ByteString- renderAliasPart (_ `As` name) = renderAlias name- renderColumnValuePart (value `As` _) = case value of- Default -> "DEFAULT"- Set expression -> renderExpression expression+ , columns ~ TableToColumns table+ , row0 ~ TableToRow table+ , SOP.SListI columns+ , SOP.SListI row1 )+ => QualifiedAlias sch tab+ -> QueryClause commons schemas params columns+ -> ConflictClause tab commons schemas params table+ -> ReturningClause commons schemas params '[tab ::: row0] row1+ -> Manipulation commons schemas params row1+insertInto tab qry conflict ret = UnsafeManipulation $+ "INSERT" <+> "INTO" <+> renderSQL tab+ <+> renderSQL qry+ <> renderSQL conflict+ <> renderSQL ret --- | Insert a single row.-insertRow- :: ( SOP.SListI columns- , SOP.SListI results+-- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.+insertInto_+ :: ( Has sch schemas schema , Has tab schema ('Table table)+ , columns ~ TableToColumns table , row ~ TableToRow table- , columns ~ TableToColumns table )- => Alias tab -- ^ table to insert into- -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert- -> ConflictClause schema table params- -- ^ what to do in case of constraint conflict- -> ReturningClause schema params row results -- ^ results to return- -> Manipulation schema params results-insertRow tab rw = insertRows tab rw []+ , SOP.SListI columns )+ => QualifiedAlias sch tab+ -> QueryClause commons schemas params columns+ -> Manipulation commons schemas params '[]+insertInto_ tab qry =+ insertInto tab qry OnConflictDoRaise (Returning_ Nil) --- | Insert multiple rows returning `Nil` and raising an error on conflicts.-insertRows_- :: ( SOP.SListI columns- , Has tab schema ('Table table)- , columns ~ TableToColumns table )- => Alias tab -- ^ table to insert into- -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert- -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert- -> Manipulation schema params '[]-insertRows_ tab rw rws =- insertRows tab rw rws OnConflictDoRaise (Returning Nil)+-- | A `QueryClause` describes what to `insertInto` a table.+data QueryClause commons schemas params columns where+ -- | `Values` describes `NP` lists of `Aliased` `Optional` `Expression`s+ -- whose `ColumnsType` must match the tables'.+ Values+ :: SOP.SListI columns+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]+ -> QueryClause commons schemas params columns+ -- | `Select` describes a subquery that permits use of `Optional` `Expression`s.+ Select+ :: SOP.SListI columns+ => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns+ -> TableExpression '[] commons grp schemas params from+ -> QueryClause commons schemas params columns+ -- | `Subquery` describes a subquery whose `RowType` must match the tables'.+ Subquery+ :: ColumnsToRow columns ~ row+ => Query '[] commons schemas params row+ -> QueryClause commons schemas params columns --- | Insert a single row returning `Nil` and raising an error on conflicts.-insertRow_- :: ( SOP.SListI columns- , Has tab schema ('Table table)- , columns ~ TableToColumns table )- => Alias tab -- ^ table to insert into- -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert- -> Manipulation schema params '[]-insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)+instance RenderSQL (QueryClause commons schemas params columns) where+ renderSQL = \case+ Values row0 rows ->+ parenthesized (renderCommaSeparated renderSQLPart row0)+ <+> "VALUES"+ <+> commaSeparated+ ( parenthesized+ . renderCommaSeparated renderValuePart <$> row0 : rows )+ Select row0 tab ->+ parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)+ <+> "SELECT"+ <+> renderCommaSeparatedMaybe renderValuePartMaybe row0+ <+> renderSQL tab+ Subquery qry -> renderQuery qry+ where+ renderSQLPartMaybe, renderValuePartMaybe+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column+ -> Maybe ByteString+ renderSQLPartMaybe = \case+ Default `As` _ -> Nothing+ Set _ `As` name -> Just $ renderSQL name+ renderValuePartMaybe = \case+ Default `As` _ -> Nothing+ Set value `As` _ -> Just $ renderExpression value+ renderSQLPart, renderValuePart+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column+ -> ByteString+ renderSQLPart (_ `As` name) = renderSQL name+ renderValuePart (value `As` _) = renderSQL value --- | Insert a `Query`.-insertQuery- :: ( SOP.SListI columns- , SOP.SListI results- , Has tab schema ('Table table)- , row ~ TableToRow table- , columns ~ TableToColumns table )- => Alias tab -- ^ table to insert into- -> Query schema params (TableToRow table)- -> ConflictClause schema table params- -- ^ what to do in case of constraint conflict- -> ReturningClause schema params row results -- ^ results to return- -> Manipulation schema params results-insertQuery tab query conflict returning = UnsafeManipulation $- "INSERT" <+> "INTO" <+> renderAlias tab- <+> renderQuery query- <> renderConflictClause conflict- <> renderReturningClause returning+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s+-- whose `ColumnsType` must match the tables'.+pattern Values_+ :: SOP.SListI columns+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns+ -> QueryClause commons schemas params columns+pattern Values_ vals = Values vals [] --- | Insert a `Query` returning `Nil` and raising an error on conflicts.-insertQuery_- :: ( SOP.SListI columns- , Has tab schema ('Table table)- , columns ~ TableToColumns table )- => Alias tab -- ^ table to insert into- -> Query schema params (TableToRow table)- -> Manipulation schema params '[]-insertQuery_ tab query =- insertQuery tab query OnConflictDoRaise (Returning Nil)+-- | `Optional` is either `Default` or a value, parameterized by an appropriate+-- `ColumnConstraint`.+data Optional expr ty where+ -- | Use the `Default` value for a column.+ Default :: Optional expr ('Def :=> ty)+ -- | `Set` a value for a column.+ Set :: expr ty -> Optional expr (def :=> ty) --- | `ColumnValue`s are values to insert or update in a row.--- `Same` updates with the same value.--- `Default` inserts or updates with the @DEFAULT@ value.--- `Set` sets a value to be an `Expression`, which can refer to--- existing value in the row for an update.-data ColumnValue- (schema :: SchemaType)- (columns :: RowType)- (params :: [NullityType])- (ty :: ColumnType)- where- Same :: ColumnValue schema (column ': columns) params ty- Default :: ColumnValue schema columns params ('Def :=> ty)- Set- :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty)- -> ColumnValue schema columns params (constraint :=> ty)+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where+ renderSQL = \case+ Default -> "DEFAULT"+ Set expr -> renderSQL expr -- | A `ReturningClause` computes and return value(s) based -- on each row actually inserted, updated or deleted. This is primarily@@ -347,75 +373,98 @@ -- serial sequence number. However, any expression using the table's columns -- is allowed. Only rows that were successfully inserted or updated or -- deleted will be returned. For example, if a row was locked--- but not updated because an `OnConflictDoUpdate` condition was not satisfied,--- the row will not be returned. `ReturningStar` will return all columns+-- but not updated because an `OnConflict` `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 -- values are desired.-data ReturningClause- (schema :: SchemaType)- (params :: [NullityType])- (row0 :: RowType)- (row1 :: RowType)- where- ReturningStar- :: ReturningClause schema params row row- Returning- :: NP (Aliased (Expression schema '[table ::: row0] 'Ungrouped params)) row1- -> ReturningClause schema params row0 row1+newtype ReturningClause commons schemas params from row =+ Returning (Selection '[] commons 'Ungrouped schemas params from row) --- | Render a `ReturningClause`.-renderReturningClause- :: SOP.SListI results- => ReturningClause schema params columns results- -> ByteString-renderReturningClause = \case- ReturningStar -> " RETURNING *"- Returning Nil -> ""- Returning results -> " RETURNING"- <+> renderCommaSeparated (renderAliasedAs renderExpression) results+instance RenderSQL (ReturningClause commons schemas params from row) where+ renderSQL = \case+ Returning (List Nil) -> ""+ Returning selection -> " RETURNING" <+> renderSQL selection +-- | `Returning` a `List`+pattern Returning_+ :: SOP.SListI row+ => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row+ -> ReturningClause commons schemas params from row+pattern Returning_ list = Returning (List list)+ -- | A `ConflictClause` specifies an action to perform upon a constraint -- violation. `OnConflictDoRaise` will raise an error.--- `OnConflictDoNothing` simply avoids inserting a row.--- `OnConflictDoUpdate` updates the existing row that conflicts with the row+-- `OnConflict` `DoNothing` simply avoids inserting a row.+-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row -- proposed for insertion.-data ConflictClause- (schema :: SchemaType)- (table :: TableType)- (params :: [NullityType]) where- OnConflictDoRaise :: ConflictClause schema table params- OnConflictDoNothing :: ConflictClause schema table params- OnConflictDoUpdate- :: (row ~ TableToRow table, columns ~ TableToColumns table)- => NP (Aliased (ColumnValue schema row params)) columns- -> [Condition schema '[t ::: row] 'Ungrouped params]- -> ConflictClause schema table params+data ConflictClause tab commons schemas params table where+ OnConflictDoRaise :: ConflictClause tab commons schemas params table+ OnConflict+ :: ConflictTarget constraints+ -> ConflictAction tab commons schemas params columns+ -> ConflictClause tab commons schemas params (constraints :=> columns) -- | Render a `ConflictClause`.-renderConflictClause- :: SOP.SListI (TableToColumns table)- => ConflictClause schema table params+instance SOP.SListI (TableToColumns table)+ => RenderSQL (ConflictClause tab commons schemas params table) where+ renderSQL = \case+ OnConflictDoRaise -> ""+ OnConflict target action -> " ON CONFLICT"+ <+> renderSQL target <+> renderSQL action++{- |+`ConflictAction` specifies an alternative `OnConflict` action.+It can be either `DoNothing`, or a `DoUpdate` clause specifying+the exact details of the `update` action to be performed in case of a conflict.+The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the+existing row using the table's name (or an alias), and to rows proposed+for insertion using the special @#excluded@ table.+-}+data ConflictAction tab commons schemas params columns where+ -- | `OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.+ DoNothing :: ConflictAction tab commons schemas params columns+ -- | `OnConflict` `DoUpdate` updates the existing row that conflicts+ -- with the row proposed for insertion as its alternative action.+ DoUpdate+ :: ( row ~ ColumnsToRow columns+ , SOP.SListI columns+ , columns ~ (col0 ': cols)+ , SOP.All (HasIn columns) subcolumns+ , AllUnique subcolumns )+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns+ -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]+ -- ^ WHERE `Condition`s+ -> ConflictAction tab commons schemas params columns++instance RenderSQL (ConflictAction tab commons schemas params columns) where+ renderSQL = \case+ DoNothing -> "DO NOTHING"+ DoUpdate updates whs'+ -> "DO UPDATE SET"+ <+> renderCommaSeparated renderUpdate updates+ <> case whs' of+ [] -> ""+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)++renderUpdate+ :: (forall x. RenderSQL (expr x))+ => Aliased (Optional expr) ty -> ByteString-renderConflictClause = \case- OnConflictDoRaise -> ""- OnConflictDoNothing -> " ON CONFLICT DO NOTHING"- OnConflictDoUpdate updates whs'- -> " ON CONFLICT DO UPDATE SET"- <+> renderCommaSeparatedMaybe renderUpdate updates- <> case whs' of- [] -> ""- wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)- where- renderUpdate- :: Aliased (ColumnValue schema columns params) column- -> Maybe ByteString- renderUpdate = \case- Same `As` _ -> Nothing- Default `As` column -> Just $- renderAlias column <+> "=" <+> "DEFAULT"- Set expression `As` column -> Just $- renderAlias column <+> "=" <+> renderExpression expression+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr +-- | A `ConflictTarget` specifies the constraint violation that triggers a+-- `ConflictAction`.+data ConflictTarget constraints where+ OnConstraint+ :: Has con constraints constraint+ => Alias con+ -> ConflictTarget constraints++-- | Render a `ConflictTarget`+instance RenderSQL (ConflictTarget constraints) where+ renderSQL (OnConstraint con) =+ "ON" <+> "CONSTRAINT" <+> renderSQL con+ {----------------------------------------- UPDATE statements -----------------------------------------}@@ -424,76 +473,98 @@ -- in all rows that satisfy the condition. update :: ( SOP.SListI columns- , SOP.SListI results+ , SOP.SListI row1+ , db ~ (commons :=> schemas)+ , Has sch schemas schema , Has tab schema ('Table table)- , row ~ TableToRow table- , columns ~ TableToColumns table )- => Alias tab -- ^ table to update- -> NP (Aliased (ColumnValue schema row params)) columns+ , row0 ~ TableToRow table+ , columns ~ TableToColumns table+ , SOP.All (HasIn columns) subcolumns+ , AllUnique subcolumns )+ => QualifiedAlias sch tab -- ^ table to update+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns -- ^ modified values to replace old values- -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0] -- ^ condition under which to perform update on a row- -> ReturningClause schema params row results -- ^ results to return- -> Manipulation schema params results+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return+ -> Manipulation commons schemas params row1 update tab columns wh returning = UnsafeManipulation $ "UPDATE"- <+> renderAlias tab+ <+> renderSQL tab <+> "SET"- <+> renderCommaSeparatedMaybe renderUpdate columns- <+> "WHERE" <+> renderExpression wh- <> renderReturningClause returning- where- renderUpdate- :: Aliased (ColumnValue schema columns params) column- -> Maybe ByteString- renderUpdate = \case- Same `As` _ -> Nothing- Default `As` column -> Just $- renderAlias column <+> "=" <+> "DEFAULT"- Set expression `As` column -> Just $- renderAlias column <+> "=" <+> renderExpression expression+ <+> renderCommaSeparated renderUpdate columns+ <+> "WHERE" <+> renderSQL wh+ <> renderSQL returning -- | Update a row returning `Nil`. update_ :: ( SOP.SListI columns+ , db ~ (commons :=> schemas)+ , Has sch schemas schema , Has tab schema ('Table table) , row ~ TableToRow table- , columns ~ TableToColumns table )- => Alias tab -- ^ table to update- -> NP (Aliased (ColumnValue schema row params)) columns+ , columns ~ TableToColumns table+ , SOP.All (HasIn columns) subcolumns+ , AllUnique subcolumns )+ => QualifiedAlias sch tab -- ^ table to update+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns -- ^ modified values to replace old values- -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row] -- ^ condition under which to perform update on a row- -> Manipulation schema params '[]-update_ tab columns wh = update tab columns wh (Returning Nil)+ -> Manipulation commons schemas params '[]+update_ tab columns wh = update tab columns wh (Returning_ Nil) {----------------------------------------- DELETE statements -----------------------------------------} --- | Delete rows of a table.+-- | Specify additional tables.+data UsingClause commons schemas params from where+ -- | No `UsingClause`+ NoUsing :: UsingClause commons schemas params '[]+ -- | 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.+ Using+ :: FromClause '[] commons schemas params from+ -> UsingClause commons schemas params from++-- | Delete rows from a table. deleteFrom- :: ( SOP.SListI results+ :: ( SOP.SListI row1+ , db ~ (commons :=> schemas)+ , Has sch schemas schema , Has tab schema ('Table table)- , row ~ TableToRow table+ , row0 ~ TableToRow table , columns ~ TableToColumns table )- => Alias tab -- ^ table to delete from- -> Condition schema '[tab ::: row] 'Ungrouped params+ => QualifiedAlias sch tab -- ^ table to delete from+ -> UsingClause commons schemas params from+ -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from) -- ^ condition under which to delete a row- -> ReturningClause schema params row results -- ^ results to return- -> Manipulation schema params results-deleteFrom tab wh returning = UnsafeManipulation $- "DELETE FROM" <+> renderAlias tab- <+> "WHERE" <+> renderExpression wh- <> renderReturningClause returning+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return+ -> Manipulation commons schemas params row1+deleteFrom tab using wh returning = UnsafeManipulation $+ "DELETE FROM"+ <+> renderSQL tab+ <> case using of+ NoUsing -> ""+ Using tables -> " USING" <+> renderSQL tables+ <+> "WHERE" <+> renderSQL wh+ <> renderSQL returning -- | Delete rows returning `Nil`. deleteFrom_- :: ( Has tab schema ('Table table)+ :: ( db ~ (commons :=> schemas)+ , Has sch schemas schema+ , Has tab schema ('Table table) , row ~ TableToRow table , columns ~ TableToColumns table )- => Alias tab -- ^ table to delete from- -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)+ => QualifiedAlias sch tab -- ^ table to delete from+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row] -- ^ condition under which to delete a row- -> Manipulation schema params '[]-deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)+ -> Manipulation commons schemas params '[]+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
src/Squeal/PostgreSQL/Migration.hs view
@@ -8,8 +8,13 @@ This module defines a `Migration` type to safely change the schema of your database over time. Let's see an example! +First turn on some extensions.+ >>> :set -XDataKinds -XOverloadedLabels >>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators++Next, let's define our `TableType`s.+ >>> :{ type UsersTable = '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>@@ -20,7 +25,7 @@ >>> :{ type EmailsTable =- '[ "pk_emails" ::: 'PrimaryKey '["id"]+ '[ "pk_emails" ::: 'PrimaryKey '["id"] , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4@@ -29,228 +34,292 @@ ] :} +Now we can define some `Migration`s to make our tables.+ >>> :{ let- makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable]+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]] makeUsers = Migration { name = "make users table"- , up = void . define $- createTable #users+ , up = createTable #users ( serial `as` #id :*- (text & notNullable) `as` #name )+ notNullable text `as` #name ) ( primaryKey #id `as` #pk_users )- , down = void . define $ dropTable #users+ , down = dropTable #users } :} >>> :{ let- makeEmails :: Migration IO '["users" ::: 'Table UsersTable]- '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]+ '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]] makeEmails = Migration { name = "make emails table"- , up = void . define $- createTable #emails+ , up = createTable #emails ( serial `as` #id :*- (int & notNullable) `as` #user_id :*- (text & nullable) `as` #email )+ notNullable int `as` #user_id :*+ nullable text `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `as` #fk_user_id )- , down = void . define $ dropTable #emails+ , down = dropTable #emails } :} -Now that we have a couple migrations we can chain them together.+Now that we have a couple migrations we can chain them together into an `AlignedList`. >>> let migrations = makeUsers :>> makeEmails :>> Done ->>> :{-let- numMigrations- :: Has "schema_migrations" schema ('Table MigrationsTable)- => PQ schema schema IO ()- numMigrations = do- result <- runQuery (selectStar (from (table (#schema_migrations `as` #m))))- num <- ntuples result- liftBase $ print num-:}+Now run the migrations. +>>> import Control.Monad.IO.Class >>> :{ withConnection "host=localhost port=5432 dbname=exampledb" $ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;") -- suppress notices+ & pqThen (liftIO (putStrLn "Migrate")) & pqThen (migrateUp migrations)- & pqThen numMigrations+ & pqThen (liftIO (putStrLn "Rollback")) & pqThen (migrateDown migrations)- & pqThen numMigrations :}-Row 2-Row 0+Migrate+Rollback++We can also create a simple executable using `defaultMain`.++>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations++>>> withArgs [] main+Invalid command: "". Use:+migrate to run all available migrations+rollback to rollback all available migrations+status to display migrations run and migrations left to run++>>> withArgs ["status"] main+Migrations already run:+ None+Migrations left to run:+ - make users table+ - make emails table++>>> withArgs ["migrate"] main+Migrations already run:+ - make users table+ - make emails table+Migrations left to run:+ None++>>> withArgs ["rollback"] main+Migrations already run:+ None+Migrations left to run:+ - make users table+ - make emails table++In addition to enabling `Migration`s using pure SQL `Definition`s for+the `up` and `down` instructions, you can also perform impure `IO` actions+by using a `Migration`s over the `Terminally` `PQ` `IO` category. -} {-# LANGUAGE DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances , GADTs , LambdaCase- , PolyKinds , OverloadedLabels+ , OverloadedStrings+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes , TypeApplications- , FlexibleContexts , TypeOperators #-} module Squeal.PostgreSQL.Migration ( -- * Migration Migration (..)- , migrateUp- , migrateDown- -- * Migration table+ , Migratory (..)+ , Terminally (..)+ , terminally+ , pureMigration , MigrationsTable- , createMigrations- , insertMigration- , deleteMigration- , selectMigration+ , defaultMain ) where +import Control.Category import Control.Monad-import Control.Monad.Base-import Control.Monad.Trans.Control-import Generics.SOP (K(..))+import Data.ByteString (ByteString)+import Data.Foldable (traverse_) import Data.Function ((&))+import Data.List ((\\)) import Data.Text (Text)+import Data.Time (UTCTime)+import Prelude hiding ((.), id)+import System.Environment+import UnliftIO (MonadIO (..)) -import Squeal.PostgreSQL+import qualified Data.Text.IO as Text (putStrLn)+import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC --- | A `Migration` should contain an inverse pair of--- `up` and `down` instructions and a unique `name`.-data Migration io schema0 schema1 = Migration+import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Binary+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Expression.Comparison+import Squeal.PostgreSQL.Expression.Parameter+import Squeal.PostgreSQL.Expression.Time+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.PQ+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Transaction++-- | A `Migration` is a named "isomorphism" over a given category.+-- It should contain an inverse pair of `up` and `down`+-- instructions and a unique `name`.+data Migration p schemas0 schemas1 = Migration { name :: Text -- ^ The `name` of a `Migration`. -- Each `name` in a `Migration` should be unique.- , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.- , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.+ } deriving (GHC.Generic)++{- |+A `Migratory` @p@ is a `Category` for which one can execute or rewind+an `AlignedList` of `Migration`s over @p@. This includes the category of pure+SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.+-}+class Category p => Migratory p where++ {- |+ Run an `AlignedList` of `Migration`s.+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;+ if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.+ -}+ migrateUp+ :: AlignedList (Migration p) schemas0 schemas1+ -> PQ schemas0 schemas1 IO ()++ {- |+ Rewind an `AlignedList` of `Migration`s.+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;+ if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.+ -}+ migrateDown+ :: AlignedList (Migration p) schemas0 schemas1+ -> PQ schemas1 schemas0 IO ()++instance Migratory Definition where+ migrateUp = migrateUp . mapAligned pureMigration+ migrateDown = migrateDown . mapAligned pureMigration++{- | `Terminally` turns an indexed monad transformer and the monad it transforms+into a category by restricting the return type to @()@ and permuting the type variables.+This is similar to how applying a monad to @()@ yields a monoid.+Since a `Terminally` action has a trivial return value, the only reason+to run one is for the side effects, in particular database and other IO effects.+-}+newtype Terminally trans monad x0 x1 = Terminally+ { runTerminally :: trans x0 x1 monad () }+ deriving GHC.Generic++instance+ ( IndexedMonadTransPQ trans+ , Monad monad+ , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )+ => Category (Terminally trans monad) where+ id = Terminally (return ())+ Terminally g . Terminally f = Terminally $ pqThen g f++-- | `terminally` ignores the output of a computation, returning @()@ and+-- wrapping it up into a `Terminally`. You can lift an action in the base monad+-- by using @terminally . lift@.+terminally+ :: Functor (trans x0 x1 monad)+ => trans x0 x1 monad ignore+ -> Terminally trans monad x0 x1+terminally = Terminally . void++-- | A `pureMigration` turns a `Migration` involving only pure SQL+-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.+pureMigration+ :: Migration Definition schemas0 schemas1+ -> Migration (Terminally PQ IO) schemas0 schemas1+pureMigration migration = Migration+ { name = name migration+ , up = terminally . define $ up migration+ , down = terminally . define $ down migration } --- | Run `Migration`s by creating the `MigrationsTable`--- if it does not exist and then in a transaction, for each each `Migration`--- query to see if the `Migration` is executed. If not, then--- execute the `Migration` and insert its row in the `MigrationsTable`.-migrateUp- :: MonadBaseControl IO io- => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run- -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- io ()-migrateUp migration =- define createMigrations- & pqBind okResult- & pqThen (transactionallySchema_ (upMigrations migration))- where+instance Migratory (Terminally PQ IO) where - upMigrations- :: MonadBaseControl IO io- => AlignedList (Migration io) schema0 schema1- -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- io ()- upMigrations = \case- Done -> return ()- step :>> steps -> upMigration step & pqThen (upMigrations steps)+ migrateUp migration = unsafePQ . transactionally_ $ do+ define createMigrations+ upMigrations migration - upMigration- :: MonadBase IO io- => Migration io schema0 schema1 -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- io ()- upMigration step =- queryExecuted step- & pqBind (\ executed ->- if executed == 1 -- up step has already been executed- then PQ (\ _ -> return (K ())) -- unsafely switch schemas- else- pqEmbed (up step) -- safely switch schemas- & pqThen (manipulateParams insertMigration (Only (name step)))- -- insert execution record- & pqBind okResult)+ where - queryExecuted- :: MonadBase IO io- => Migration io schema0 schema1 -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- io Row- queryExecuted step = do- result <- runQueryParams selectMigration (Only (name step))- okResult result- ntuples result+ upMigrations+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1+ -> PQ MigrationsSchemas MigrationsSchemas IO ()+ upMigrations = \case+ Done -> return ()+ step :>> steps -> upMigration step >> upMigrations steps --- | Rewind `Migration`s by creating the `MigrationsTable`--- if it does not exist and then in a transaction, for each each `Migration`--- query to see if the `Migration` is executed. If it is, then--- rewind the `Migration` and delete its row in the `MigrationsTable`.-migrateDown- :: MonadBaseControl IO io- => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind- -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- io ()-migrateDown migrations =- define createMigrations- & pqBind okResult- & pqThen (transactionallySchema_ (downMigrations migrations))- where+ upMigration+ :: Migration (Terminally PQ IO) schemas0 schemas1+ -> PQ MigrationsSchemas MigrationsSchemas IO ()+ upMigration step = do+ executed <- queryExecuted step+ unless (executed == 1) $ do+ unsafePQ . runTerminally $ up step+ manipulateParams_ insertMigration (Only (name step)) - downMigrations- :: MonadBaseControl IO io- => AlignedList (Migration io) schema0 schema1 -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- io ()- downMigrations = \case- Done -> return ()- step :>> steps -> downMigrations steps & pqThen (downMigration step)+ queryExecuted+ :: Migration (Terminally PQ IO) schemas0 schemas1+ -> PQ MigrationsSchemas MigrationsSchemas IO Row+ queryExecuted step = do+ result <- runQueryParams selectMigration (Only (name step))+ ntuples result - downMigration- :: MonadBase IO io- => Migration io schema0 schema1 -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- ("schema_migrations" ::: 'Table MigrationsTable ': schema0)- io ()- downMigration step =- queryExecuted step- & pqBind (\ executed ->- if executed == 0 -- up step has not been executed- then PQ (\ _ -> return (K ())) -- unsafely switch schemas- else- pqEmbed (down step) -- safely switch schemas- & pqThen (manipulateParams deleteMigration (Only (name step)))- -- delete execution record- & pqBind okResult)+ migrateDown migrations = unsafePQ . transactionally_ $ do+ define createMigrations+ downMigrations migrations - queryExecuted- :: MonadBase IO io- => Migration io schema0 schema1 -> PQ- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- ("schema_migrations" ::: 'Table MigrationsTable ': schema1)- io Row- queryExecuted step = do- result <- runQueryParams selectMigration (Only (name step))- okResult result- ntuples result+ where -okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()-okResult result = do- status <- resultStatus result- when (not (status `elem` [CommandOk, TuplesOk])) $ do- errorMessageMaybe <- resultErrorMessage result- case errorMessageMaybe of- Nothing -> error "migrateDown: unknown error"- Just msg -> error ("migrationDown: " <> show msg)+ downMigrations+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1+ -> PQ MigrationsSchemas MigrationsSchemas IO ()+ downMigrations = \case+ Done -> return ()+ step :>> steps -> downMigrations steps >> downMigration step + downMigration+ :: Migration (Terminally PQ IO) schemas0 schemas1+ -> PQ MigrationsSchemas MigrationsSchemas IO ()+ downMigration step = do+ executed <- queryExecuted step+ unless (executed == 0) $ do+ unsafePQ . runTerminally $ down step+ manipulateParams_ deleteMigration (Only (name step))++ queryExecuted+ :: Migration (Terminally PQ IO) schemas0 schemas1+ -> PQ MigrationsSchemas MigrationsSchemas IO Row+ queryExecuted step = do+ result <- runQueryParams selectMigration (Only (name step))+ ntuples result++unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK+ -- | The `TableType` for a Squeal migration. type MigrationsTable = '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>@@ -258,10 +327,19 @@ , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz ] +data MigrationRow =+ MigrationRow { migrationName :: Text+ , migrationTime :: UTCTime }+ deriving (GHC.Generic, Show)++instance SOP.Generic MigrationRow+instance SOP.HasDatatypeInfo MigrationRow++type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]+type MigrationsSchemas = Public MigrationsSchema+ -- | Creates a `MigrationsTable` if it does not already exist.-createMigrations- :: Has "schema_migrations" schema ('Table MigrationsTable)- => Definition schema schema+createMigrations :: Definition MigrationsSchemas MigrationsSchemas createMigrations = createTableIfNotExists #schema_migrations ( (text & notNullable) `as` #name :*@@ -269,27 +347,100 @@ `as` #executed_at ) ( unique #name `as` #migrations_unique_name ) --- | Inserts a `Migration` into the `MigrationsTable`-insertMigration- :: Has "schema_migrations" schema ('Table MigrationsTable)- => Manipulation schema '[ 'NotNull 'PGtext] '[]-insertMigration = insertRow_ #schema_migrations- ( Set (param @1) `as` #name :*- Default `as` #executed_at )+-- | Inserts a `Migration` into the `MigrationsTable`, returning+-- the time at which it was inserted.+insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()+insertMigration = insertInto_ #schema_migrations+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at)) --- | Deletes a `Migration` from the `MigrationsTable`-deleteMigration- :: Has "schema_migrations" schema ('Table MigrationsTable)- => Manipulation schema '[ 'NotNull 'PGtext ] '[]+-- | Deletes a `Migration` from the `MigrationsTable`, returning+-- the time at which it was inserted.+deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) () deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1) -- | Selects a `Migration` from the `MigrationsTable`, returning--- the time at which it was executed.+-- the time at which it was inserted. selectMigration- :: Has "schema_migrations" schema ('Table MigrationsTable)- => Query schema '[ 'NotNull 'PGtext ]- '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]-selectMigration = select- (#executed_at `as` #executed_at)- ( from (table (#schema_migrations `as` #m))- & where_ (#name .== param @1))+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)+selectMigration = select_ (#executed_at `as` #fromOnly)+ $ from (table (#schema_migrations))+ & where_ (#name .== param @1)++selectMigrations :: Query_ MigrationsSchemas () MigrationRow+selectMigrations = select_+ (#name `as` #migrationName :* #executed_at `as` #migrationTime)+ (from (table #schema_migrations))++data MigrateCommand+ = MigrateStatus+ | MigrateUp+ | MigrateDown deriving (GHC.Generic, Show)++{- | `defaultMain` creates a simple executable+from a connection string and a list of `Migration`s. -}+defaultMain+ :: Migratory p+ => ByteString+ -- ^ connection string+ -> AlignedList (Migration p) db0 db1+ -- ^ migrations+ -> IO ()+defaultMain connectTo migrations = do+ command <- readCommandFromArgs+ maybe (pure ()) performCommand command++ where++ performCommand :: MigrateCommand -> IO ()+ performCommand = \case+ MigrateStatus -> withConnection connectTo $+ suppressNotices >> migrateStatus+ MigrateUp -> withConnection connectTo $+ suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus+ MigrateDown -> withConnection connectTo $+ suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus++ migrateStatus :: PQ schema schema IO ()+ migrateStatus = unsafePQ $ do+ runNames <- getRunMigrationNames+ let names = extractList name migrations+ unrunNames = names \\ runNames+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames++ suppressNotices :: PQ schema schema IO ()+ suppressNotices = manipulate_ $+ UnsafeManipulation "SET client_min_messages TO WARNING;"++ readCommandFromArgs :: IO (Maybe MigrateCommand)+ readCommandFromArgs = getArgs >>= \case+ ["migrate"] -> pure . Just $ MigrateUp+ ["rollback"] -> pure . Just $ MigrateDown+ ["status"] -> pure . Just $ MigrateStatus+ args -> displayUsage args >> pure Nothing++ displayUsage :: [String] -> IO ()+ displayUsage args = do+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"+ putStrLn "migrate to run all available migrations"+ putStrLn "rollback to rollback all available migrations"+ putStrLn "status to display migrations run and migrations left to run"++ getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]+ getRunMigrationNames =+ fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)++ displayListOfNames :: [Text] -> IO ()+ displayListOfNames [] = Text.putStrLn " None"+ displayListOfNames xs =+ let singleName n = Text.putStrLn $ " - " <> n+ in traverse_ singleName xs++ displayUnrunned :: [Text] -> IO ()+ displayUnrunned unrunned =+ Text.putStrLn "Migrations left to run:"+ >> displayListOfNames unrunned++ displayRunned :: [Text] -> IO ()+ displayRunned runned =+ Text.putStrLn "Migrations already run:"+ >> displayListOfNames runned
+ src/Squeal/PostgreSQL/PG.hs view
@@ -0,0 +1,366 @@+{-|+Module: Squeal.PostgreSQL.PG+Description: Embedding of Haskell types into Postgres's type system+Copyright: (c) Eitan Chatav, 2010+Maintainer: eitan@morphism.tech+Stability: experimental++`Squeal.PostgreSQL.PG` provides type families for turning Haskell+`Type`s into corresponding Postgres types.+-}+{-# LANGUAGE+ AllowAmbiguousTypes+ , DeriveFoldable+ , DeriveFunctor+ , DeriveGeneric+ , DeriveTraversable+ , DefaultSignatures+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.PG+ ( -- * PG embeddings+ PG+ , NullPG+ , TuplePG+ , RowPG+ -- * Storage newtypes+ , Money (..)+ , Json (..)+ , Jsonb (..)+ , Composite (..)+ , Enumerated (..)+ , VarArray (..)+ , FixArray (..)+ , SOP.P (..)+ -- * Type families+ , LabelsPG+ , DimPG+ , FixPG+ , TupleOf+ , TupleCodeOf+ , RowOf+ , ConstructorsOf+ , ConstructorNameOf+ , ConstructorNamesOf+ ) where++import Data.Aeson (Value)+import Data.Kind (Type)+import Data.Int (Int16, Int32, Int64)+import Data.Scientific (Scientific)+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)+import Data.Vector (Vector)+import Data.Word (Word16, Word32, Word64)+import Data.UUID.Types (UUID)+import GHC.TypeLits+import Network.IP.Addr (NetAddr, IP)++import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.Text.Lazy as Lazy (Text)+import qualified Data.Text as Strict (Text)+import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP+import qualified Generics.SOP.Record as SOP+import qualified Generics.SOP.Type.Metadata as Type++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> import Data.Text (Text)++{- | The `PG` type family embeds a subset of Haskell types+as Postgres types. As an open type family, `PG` is extensible.++>>> :kind! PG LocalTime+PG LocalTime :: PGType+= 'PGtimestamp++>>> newtype MyDouble = My Double+>>> :set -XTypeFamilies+>>> type instance PG MyDouble = 'PGfloat8+-}+type family PG (hask :: Type) :: PGType+-- | `PGbool`+type instance PG Bool = 'PGbool+-- | `PGint2`+type instance PG Int16 = 'PGint2+-- | `PGint4`+type instance PG Int32 = 'PGint4+-- | `PGint8`+type instance PG Int64 = 'PGint8+-- | `PGint2`+type instance PG Word16 = 'PGint2+-- | `PGint4`+type instance PG Word32 = 'PGint4+-- | `PGint8`+type instance PG Word64 = 'PGint8+-- | `PGnumeric`+type instance PG Scientific = 'PGnumeric+-- | `PGfloat4`+type instance PG Float = 'PGfloat4+-- | `PGfloat8`+type instance PG Double = 'PGfloat8+-- | `PGchar` @1@+type instance PG Char = 'PGchar 1+-- | `PGtext`+type instance PG Strict.Text = 'PGtext+-- | `PGtext`+type instance PG Lazy.Text = 'PGtext+-- | `PGtext`+type instance PG String = 'PGtext+-- | `PGbytea`+type instance PG Strict.ByteString = 'PGbytea+-- | `PGbytea`+type instance PG Lazy.ByteString = 'PGbytea+-- | `PGtimestamp`+type instance PG LocalTime = 'PGtimestamp+-- | `PGtimestamptz`+type instance PG UTCTime = 'PGtimestamptz+-- | `PGdate`+type instance PG Day = 'PGdate+-- | `PGtime`+type instance PG TimeOfDay = 'PGtime+-- | `PGtimetz`+type instance PG (TimeOfDay, TimeZone) = 'PGtimetz+-- | `PGinterval`+type instance PG DiffTime = 'PGinterval+-- | `PGuuid`+type instance PG UUID = 'PGuuid+-- | `PGinet`+type instance PG (NetAddr IP) = 'PGinet+-- | `PGjson`+type instance PG Value = 'PGjson++{-| The `LabelsPG` type family calculates the constructors of a+Haskell enum type.++>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic+>>> instance SOP.Generic Schwarma+>>> instance SOP.HasDatatypeInfo Schwarma+>>> :kind! LabelsPG Schwarma+LabelsPG Schwarma :: [Type.ConstructorName]+= '["Beef", "Lamb", "Chicken"]+-}+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where+ LabelsPG hask =+ ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))++{- |+`RowPG` turns a Haskell `Type` into a `RowType`.++`RowPG` may be applied to normal Haskell record types provided they+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;++>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic+>>> instance SOP.Generic Person+>>> instance SOP.HasDatatypeInfo Person+>>> :kind! RowPG Person+RowPG Person :: [(Symbol, NullityType)]+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]+-}+type family RowPG (hask :: Type) :: RowType where+ RowPG hask = RowOf (SOP.RecordCodeOf hask)++-- | `RowOf` applies `NullPG` to the fields of a list.+type family RowOf (record :: [(Symbol, Type)]) :: RowType where+ RowOf '[] = '[]+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record++{- | `NullPG` turns a Haskell type into a `NullityType`.++>>> :kind! NullPG Double+NullPG Double :: NullityType+= 'NotNull 'PGfloat8+>>> :kind! NullPG (Maybe Double)+NullPG (Maybe Double) :: NullityType+= 'Null 'PGfloat8+-}+type family NullPG (hask :: Type) :: NullityType where+ NullPG (Maybe hask) = 'Null (PG hask)+ NullPG hask = 'NotNull (PG hask)++{- | `TuplePG` turns a Haskell tuple type (including record types) into+the corresponding list of `NullityType`s.++>>> :kind! TuplePG (Double, Maybe Char)+TuplePG (Double, Maybe Char) :: [NullityType]+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]+-}+type family TuplePG (hask :: Type) :: [NullityType] where+ TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))++-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.+type family TupleOf (tuple :: [Type]) :: [NullityType] where+ TupleOf '[] = '[]+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple++-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`+-- and if it's a simple product returns it, otherwise giving a `TypeError`.+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where+ TupleCodeOf hask '[tuple] = tuple+ TupleCodeOf hask '[] =+ TypeError+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."+ ':$$: 'Text "It is a void type with no constructors."+ )+ TupleCodeOf hask (_ ': _ ': _) =+ TypeError+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."+ ':$$: 'Text "It is a sum type with more than one constructor."+ )++-- | Calculates constructors of a datatype.+type family ConstructorsOf (datatype :: Type.DatatypeInfo)+ :: [Type.ConstructorInfo] where+ ConstructorsOf ('Type.ADT _module _datatype constructors) =+ constructors+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =+ '[constructor]++-- | Calculates the name of a nullary constructor, otherwise+-- generates a type error.+type family ConstructorNameOf (constructor :: Type.ConstructorInfo)+ :: Type.ConstructorName where+ ConstructorNameOf ('Type.Constructor name) = name+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError+ ('Text "ConstructorNameOf error: non-nullary constructor "+ ':<>: 'Text name)+ ConstructorNameOf ('Type.Record name _fields) = TypeError+ ('Text "ConstructorNameOf error: non-nullary constructor "+ ':<>: 'Text name)++-- | Calculate the names of nullary constructors.+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])+ :: [Type.ConstructorName] where+ ConstructorNamesOf '[] = '[]+ ConstructorNamesOf (constructor ': constructors) =+ ConstructorNameOf constructor ': ConstructorNamesOf constructors++-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.+type family DimPG (hask :: Type) :: [Nat] where+ DimPG (x,x) = 2 ': DimPG x+ DimPG (x,x,x) = 3 ': DimPG x+ DimPG (x,x,x,x) = 4 ': DimPG x+ DimPG (x,x,x,x,x) = 5 ': DimPG x+ DimPG (x,x,x,x,x,x) = 6 ': DimPG x+ DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x+ DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x+ DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x+ DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x+ DimPG x = '[]++-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.+type family FixPG (hask :: Type) :: NullityType where+ FixPG (x,x) = FixPG x+ FixPG (x,x,x) = FixPG x+ FixPG (x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x+ FixPG x = NullPG x++{- | 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 }@.++>>> import Control.Monad (void)+>>> import Control.Monad.IO.Class (liftIO)+>>> import Squeal.PostgreSQL+>>> :{+let+ roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)+ roundTrip = values_ $ parameter @1 money `as` #fromOnly+:}++>>> let input = Only (Money 20020)++>>> :{+withConnection "host=localhost port=5432 dbname=exampledb" $ do+ result <- runQueryParams roundTrip input+ Just output <- firstRow result+ liftIO . print $ input == output+:}+True+-}+newtype Money = Money { cents :: Int64 }+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGmoney`+type instance PG Money = 'PGmoney++{- | The `Json` newtype is an indication that the Haskell+type it's applied to should be stored as a `PGjson`.+-}+newtype Json hask = Json {getJson :: hask}+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGjson`+type instance PG (Json hask) = 'PGjson++{- | The `Jsonb` newtype is an indication that the Haskell+type it's applied to should be stored as a `PGjsonb`.+-}+newtype Jsonb hask = Jsonb {getJsonb :: hask}+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGjsonb`+type instance PG (Jsonb hask) = 'PGjsonb++{- | The `Composite` newtype is an indication that the Haskell+type it's applied to should be stored as a `PGcomposite`.+-}+newtype Composite record = Composite {getComposite :: record}+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGcomposite` @(@`RowPG` @hask)@+type instance PG (Composite hask) = 'PGcomposite (RowPG hask)++{- | The `Enumerated` newtype is an indication that the Haskell+type it's applied to should be stored as a `PGenum`.+-}+newtype Enumerated enum = Enumerated {getEnumerated :: enum}+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGenum` @(@`LabelsPG` @hask)@+type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)++{- | The `VarArray` newtype is an indication that the Haskell+type it's applied to should be stored as a `PGvararray`.++>>> :kind! PG (VarArray (Vector Double))+PG (VarArray (Vector Double)) :: PGType+= 'PGvararray ('NotNull 'PGfloat8)+-}+newtype VarArray arr = VarArray {getVarArray :: arr}+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGvararray` @(@`NullPG` @hask)@+type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)++{- | The `FixArray` newtype is an indication that the Haskell+type it's applied to should be stored as a `PGfixarray`.++>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))+PG (FixArray ((Double, Double), (Double, Double))) :: PGType+= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)+-}+newtype FixArray arr = FixArray {getFixArray :: arr}+ deriving (Eq, Ord, Show, Read, GHC.Generic)+-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@+type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
src/Squeal/PostgreSQL/PQ.hs view
@@ -6,12 +6,12 @@ Stability: experimental This module is where Squeal commands actually get executed by-`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing+`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`, and a `PQ` type with instances for them. Using Squeal in your application will come down to defining-the @schema@ of your database and including @PQ schema schema@ in your+the @schemas@ of your database and including @PQ schemas schemas@ in your application's monad transformer stack, giving it an instance of `MonadPQ`. This module also provides functions for retrieving rows from the `LibPQ.Result`@@ -24,6 +24,7 @@ , FunctionalDependencies , FlexibleContexts , FlexibleInstances+ , InstanceSigs , OverloadedStrings , RankNTypes , ScopedTypeVariables@@ -48,8 +49,6 @@ , evalPQ , IndexedMonadTransPQ (..) , MonadPQ (..)- , PQRun- , pqliftWith -- * Results , LibPQ.Result , LibPQ.Row@@ -65,15 +64,17 @@ , resultErrorCode -- * Exceptions , SquealException (..)+ , PQState (..)+ , okResult , catchSqueal , handleSqueal+ , trySqueal ) where -import Control.Exception.Lifted-import Control.Monad.Base+import Control.Exception (Exception, throw) import Control.Monad.Except import Control.Monad.Morph-import Control.Monad.Trans.Control+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try) import Data.ByteString (ByteString) import Data.Foldable import Data.Function ((&))@@ -83,6 +84,7 @@ import Generics.SOP import PostgreSQL.Binary.Encoding (encodingBytes) +import qualified Control.Monad.Fail as Fail import qualified Database.PostgreSQL.LibPQ as LibPQ import Squeal.PostgreSQL.Binary@@ -104,6 +106,9 @@ import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict +-- $setup+-- >>> import Squeal.PostgreSQL+ {- | Makes a new connection to the database server. This function opens a new database connection using the parameters taken@@ -130,22 +135,22 @@ with the wrong schema! -} connectdb- :: forall schema io- . MonadBase IO io+ :: forall schemas io+ . MonadIO io => ByteString -- ^ conninfo- -> io (K LibPQ.Connection schema)-connectdb = fmap K . liftBase . LibPQ.connectdb+ -> io (K LibPQ.Connection schemas)+connectdb = fmap K . liftIO . LibPQ.connectdb -- | Closes the connection to the server.-finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()-finish = liftBase . LibPQ.finish . unK+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()+finish = liftIO . LibPQ.finish . unK -- | Do `connectdb` and `finish` before and after a computation. withConnection- :: forall schema0 schema1 io x- . MonadBaseControl IO io+ :: forall schemas0 schemas1 io x+ . MonadUnliftIO io => ByteString- -> PQ schema0 schema1 io x+ -> PQ schemas0 schemas1 io x -> io x withConnection connString action = do K x <- bracket (connectdb connString) finish (unPQ action)@@ -153,47 +158,47 @@ -- | Safely `lowerConnection` to a smaller schema. lowerConnection- :: K LibPQ.Connection (table ': schema)- -> K LibPQ.Connection schema+ :: K LibPQ.Connection (schema ': schemas)+ -> K LibPQ.Connection schemas lowerConnection (K conn) = K conn -- | We keep track of the schema via an Atkey indexed state monad transformer, -- `PQ`. newtype PQ- (schema0 :: SchemaType)- (schema1 :: SchemaType)+ (schemas0 :: SchemasType)+ (schemas1 :: SchemasType) (m :: Type -> Type) (x :: Type) =- PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }+ PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) } -instance Monad m => Functor (PQ schema0 schema1 m) where+instance Monad m => Functor (PQ schemas0 schemas1 m) where fmap f (PQ pq) = PQ $ \ conn -> do K x <- pq conn return $ K (f x) --- | Run a `PQ` and keep the result and the `Connection`.+-- | Run a `PQ` and keep the result and the `LibPQ.Connection`. runPQ :: Functor m- => PQ schema0 schema1 m x- -> K LibPQ.Connection schema0- -> m (x, K LibPQ.Connection schema1)+ => PQ schemas0 schemas1 m x+ -> K LibPQ.Connection schemas0+ -> m (x, K LibPQ.Connection schemas1) runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn -- K x <- pq conn -- return (x, K (unK conn)) --- | Execute a `PQ` and discard the result but keep the `Connection`.+-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`. execPQ :: Functor m- => PQ schema0 schema1 m x- -> K LibPQ.Connection schema0- -> m (K LibPQ.Connection schema1)+ => PQ schemas0 schemas1 m x+ -> K LibPQ.Connection schemas0+ -> m (K LibPQ.Connection schemas1) execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn --- | Evaluate a `PQ` and discard the `Connection` but keep the result.+-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result. evalPQ :: Functor m- => PQ schema0 schema1 m x- -> K LibPQ.Connection schema0+ => PQ schemas0 schemas1 m x+ -> K LibPQ.Connection schemas0 -> m x evalPQ (PQ pq) conn = unK <$> pq conn @@ -201,60 +206,56 @@ -- [enriched category](https://ncatlab.org/nlab/show/enriched+category). -- An indexed monad transformer transforms a `Monad` into an indexed monad. -- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that--- support running `Definition`s using `define` and embedding a computation--- in a larger schema using `pqEmbed`.+-- support running `Definition`s using `define`. class IndexedMonadTransPQ pq where -- | indexed analog of `<*>` pqAp :: Monad m- => pq schema0 schema1 m (x -> y)- -> pq schema1 schema2 m x- -> pq schema0 schema2 m y+ => pq schemas0 schemas1 m (x -> y)+ -> pq schemas1 schemas2 m x+ -> pq schemas0 schemas2 m y -- | indexed analog of `join` pqJoin :: Monad m- => pq schema0 schema1 m (pq schema1 schema2 m y)- -> pq schema0 schema2 m y+ => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)+ -> pq schemas0 schemas2 m y pqJoin pq = pq & pqBind id -- | indexed analog of `=<<` pqBind :: Monad m- => (x -> pq schema1 schema2 m y)- -> pq schema0 schema1 m x- -> pq schema0 schema2 m y+ => (x -> pq schemas1 schemas2 m y)+ -> pq schemas0 schemas1 m x+ -> pq schemas0 schemas2 m y -- | indexed analog of flipped `>>` pqThen :: Monad m- => pq schema1 schema2 m y- -> pq schema0 schema1 m x- -> pq schema0 schema2 m y+ => pq schemas1 schemas2 m y+ -> pq schemas0 schemas1 m x+ -> pq schemas0 schemas2 m y pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2) -- | indexed analog of `<=<` pqAndThen :: Monad m- => (y -> pq schema1 schema2 m z)- -> (x -> pq schema0 schema1 m y)- -> x -> pq schema0 schema2 m z+ => (y -> pq schemas1 schemas2 m z)+ -> (x -> pq schemas0 schemas1 m y)+ -> x -> pq schemas0 schemas2 m z pqAndThen g f x = pqBind g (f x) - -- | Safely embed a computation in a larger schema.- pqEmbed- :: Monad m- => pq schema0 schema1 m x- -> pq (table ': schema0) (table : schema1) m x-- -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law+ -- | Run a `Definition` with `LibPQ.exec`. --- -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@+ -- It should be functorial in effect.+ --+ -- @define id = return ()@+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@ define- :: MonadBase IO io- => Definition schema0 schema1- -> pq schema0 schema1 io (K LibPQ.Result '[])+ :: MonadIO io+ => Definition schemas0 schemas1+ -> pq schemas0 schemas1 io () instance IndexedMonadTransPQ PQ where @@ -267,26 +268,26 @@ K x' <- x conn unPQ (f x') (K (unK conn)) - pqEmbed (PQ pq) = PQ $ \ (K conn) -> do- K x <- pq (K conn)- return $ K x- define (UnsafeDefinition q) = PQ $ \ (K conn) -> do- resultMaybe <- liftBase $ LibPQ.exec conn q+ resultMaybe <- liftIO $ LibPQ.exec conn q case resultMaybe of Nothing -> throw $ ResultException "define: LibPQ.exec returned no results"- Just result -> return $ K (K result)+ Just result -> K <$> okResult_ result -{- | `MonadPQ` is an `mtl` style constraint, similar to-`Control.Monad.State.Class.MonadState`, for using `LibPQ` to+{- | `MonadPQ` is an @mtl@ style constraint, similar to+`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to * `manipulateParams` runs a `Manipulation` with params from a type with a `ToParams` constraint. It calls `LibPQ.execParams` and doesn't afraid of anything. +* `manipulateParams_` is like `manipulateParams` for a returning-free statement.+ * `manipulate` is like `manipulateParams` for a parameter-free statement. +* `manipulate_` is like `manipulate` for a returning-free statement.+ * `runQueryParams` is like `manipulateParams` for query statements. * `runQuery` is like `runQueryParams` for a parameter-free statement.@@ -300,11 +301,11 @@ * `forPrepared` is a flipped `traversePrepared` * `traversePrepared_` is like `traversePrepared` but works on `Foldable`- containers and returns unit.+ containers for a returning-free statement. * `forPrepared_` is a flipped `traversePrepared_`. -* `liftPQ` lets you lift actions from `LibPQ` that require a connection+* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection into your monad. To define an instance, you can minimally define only `manipulateParams`,@@ -312,67 +313,77 @@ a default instance. -}-class Monad pq => MonadPQ schema pq | pq -> schema where+class Monad pq => MonadPQ schemas pq | pq -> schemas where manipulateParams :: ToParams x params- => Manipulation schema params ys- -- ^ `insertRows`, `update` or `deleteFrom`+ => Manipulation '[] schemas params ys+ -- ^ `insertInto`, `update` or `deleteFrom` -> x -> pq (K LibPQ.Result ys) default manipulateParams- :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) => ToParams x params- => Manipulation schema params ys- -- ^ `insertRows`, `update` or `deleteFrom`+ => Manipulation '[] schemas params ys+ -- ^ `insertInto`, `update` or `deleteFrom` -> x -> pq (K LibPQ.Result ys) manipulateParams manipulation params = lift $ manipulateParams manipulation params - manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)+ manipulateParams_+ :: ToParams x params+ => Manipulation '[] schemas params '[]+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> x -> pq ()+ manipulateParams_ q x = void $ manipulateParams q x++ manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys) manipulate statement = manipulateParams statement () + manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()+ manipulate_ = void . manipulate+ runQueryParams :: ToParams x params- => Query schema params ys+ => Query '[] '[] schemas params ys -- ^ `select` and friends -> x -> pq (K LibPQ.Result ys) runQueryParams = manipulateParams . queryStatement runQuery- :: Query schema '[] ys+ :: Query '[] '[] schemas '[] ys -- ^ `select` and friends -> pq (K LibPQ.Result ys) runQuery q = runQueryParams q () traversePrepared :: (ToParams x params, Traversable list)- => Manipulation schema params ys- -- ^ `insertRows`, `update`, or `deleteFrom`, and friends+ => Manipulation '[] schemas params ys+ -- ^ `insertInto`, `update`, or `deleteFrom`, and friends -> list x -> pq (list (K LibPQ.Result ys)) default traversePrepared- :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) => (ToParams x params, Traversable list)- => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))+ => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys)) traversePrepared manipulation params = lift $ traversePrepared manipulation params forPrepared :: (ToParams x params, Traversable list) => list x- -> Manipulation schema params ys- -- ^ `insertRows`, `update` or `deleteFrom`+ -> Manipulation '[] schemas params ys+ -- ^ `insertInto`, `update` or `deleteFrom` -> pq (list (K LibPQ.Result ys)) forPrepared = flip traversePrepared traversePrepared_ :: (ToParams x params, Foldable list)- => Manipulation schema params '[]- -- ^ `insertRows`, `update` or `deleteFrom`+ => Manipulation '[] schemas params '[]+ -- ^ `insertInto`, `update` or `deleteFrom` -> list x -> pq () default traversePrepared_- :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) => (ToParams x params, Foldable list)- => Manipulation schema params '[]- -- ^ `insertRows`, `update` or `deleteFrom`+ => Manipulation '[] schemas params '[]+ -- ^ `insertInto`, `update` or `deleteFrom` -> list x -> pq () traversePrepared_ manipulation params = lift $ traversePrepared_ manipulation params@@ -380,45 +391,45 @@ forPrepared_ :: (ToParams x params, Foldable list) => list x- -> Manipulation schema params '[]- -- ^ `insertRows`, `update` or `deleteFrom`+ -> Manipulation '[] schemas params '[]+ -- ^ `insertInto`, `update` or `deleteFrom` -> pq () forPrepared_ = flip traversePrepared_ liftPQ :: (LibPQ.Connection -> IO a) -> pq a default liftPQ- :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1) => (LibPQ.Connection -> IO a) -> pq a liftPQ = lift . liftPQ -instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)- => MonadPQ schema (PQ schema0 schema1 io) where+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)+ => MonadPQ schemas (PQ schemas0 schemas1 io) where manipulateParams- (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =+ (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) = PQ $ \ (K conn) -> do let toParam' encoding = (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary) params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params)) q' = q <> ";"- resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary+ resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary case resultMaybe of Nothing -> throw $ ResultException "manipulateParams: LibPQ.execParams returned no results" Just result -> do- tryResult result+ okResult_ result return $ K (K result) traversePrepared- (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =- PQ $ \ (K conn) -> liftBase $ do+ (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =+ PQ $ \ (K conn) -> liftIO $ do let temp = "temporary_statement" prepResultMaybe <- LibPQ.prepare conn temp q Nothing case prepResultMaybe of Nothing -> throw $ ResultException "traversePrepared: LibPQ.prepare returned no results"- Just prepResult -> tryResult prepResult+ Just prepResult -> okResult_ prepResult results <- for list $ \ params -> do let toParam' encoding = (encodingBytes encoding,LibPQ.Binary)@@ -428,24 +439,24 @@ Nothing -> throw $ ResultException "traversePrepared: LibPQ.execParams returned no results" Just result -> do- tryResult result+ okResult_ result return $ K result deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") case deallocResultMaybe of Nothing -> throw $ ResultException "traversePrepared: LibPQ.exec DEALLOCATE returned no results"- Just deallocResult -> tryResult deallocResult+ Just deallocResult -> okResult_ deallocResult return (K results) traversePrepared_- (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =- PQ $ \ (K conn) -> liftBase $ do+ (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =+ PQ $ \ (K conn) -> liftIO $ do let temp = "temporary_statement" prepResultMaybe <- LibPQ.prepare conn temp q Nothing case prepResultMaybe of Nothing -> throw $ ResultException "traversePrepared_: LibPQ.prepare returned no results"- Just prepResult -> tryResult prepResult+ Just prepResult -> okResult_ prepResult for_ list $ \ params -> do let toParam' encoding = (encodingBytes encoding, LibPQ.Binary)@@ -454,82 +465,79 @@ case resultMaybe of Nothing -> throw $ ResultException "traversePrepared_: LibPQ.execParams returned no results"- Just result -> tryResult result+ Just result -> okResult_ result deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";") case deallocResultMaybe of Nothing -> throw $ ResultException "traversePrepared: LibPQ.exec DEALLOCATE returned no results"- Just deallocResult -> tryResult deallocResult+ Just deallocResult -> okResult_ deallocResult return (K ()) liftPQ pq = PQ $ \ (K conn) -> do- y <- liftBase $ pq conn+ y <- liftIO $ pq conn return (K y) -instance MonadPQ schema m => MonadPQ schema (IdentityT m)-instance MonadPQ schema m => MonadPQ schema (ReaderT r m)-instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)-instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)-instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)-instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)-instance MonadPQ schema m => MonadPQ schema (MaybeT m)-instance MonadPQ schema m => MonadPQ schema (ExceptT e m)-instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)-instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)-instance MonadPQ schema m => MonadPQ schema (ContT r m)+instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)+instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)+instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)+instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)+instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)+instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)+instance MonadPQ schemas m => MonadPQ schemas (ContT r m) -instance (Monad m, schema0 ~ schema1)- => Applicative (PQ schema0 schema1 m) where+instance (Monad m, schemas0 ~ schemas1)+ => Applicative (PQ schemas0 schemas1 m) where pure x = PQ $ \ _conn -> pure (K x) (<*>) = pqAp -instance (Monad m, schema0 ~ schema1)- => Monad (PQ schema0 schema1 m) where+instance (Monad m, schemas0 ~ schemas1)+ => Monad (PQ schemas0 schemas1 m) where return = pure (>>=) = flip pqBind -instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where+instance (Monad m, schemas0 ~ schemas1)+ => Fail.MonadFail (PQ schemas0 schemas1 m) where+ fail = Fail.fail++instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where hoist f (PQ pq) = PQ (f . pq) -instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where+instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where lift m = PQ $ \ _conn -> do x <- m return (K x) -instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where+instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where embed f (PQ pq) = PQ $ \ conn -> do evalPQ (f (pq conn)) conn -instance (MonadBase b m, schema0 ~ schema1)- => MonadBase b (PQ schema0 schema1 m) where- liftBase = lift . liftBase---- | A snapshot of the state of a `PQ` computation.-type PQRun schema =- forall m x. Monad m => PQ schema schema m x -> m (K x schema)---- | Helper function in defining `MonadBaseControl` instance for `PQ`.-pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a-pqliftWith f = PQ $ \ conn ->- fmap K (f $ \ pq -> unPQ pq conn)+instance (MonadIO m, schema0 ~ schema1)+ => MonadIO (PQ schema0 schema1 m) where+ liftIO = lift . liftIO -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)- liftBaseWith f =- pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run- restoreM = PQ . const . restoreM+instance (MonadUnliftIO m, schemas0 ~ schemas1)+ => MonadUnliftIO (PQ schemas0 schemas1 m) where+ withRunInIO+ :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)+ -> PQ schemas0 schema1 m b+ withRunInIO inner = PQ $ \conn ->+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn) -- | Get a row corresponding to a given row number from a `LibPQ.Result`, -- throwing an exception if the row number is out of bounds. getRow- :: (FromRow columns y, MonadBase IO io)+ :: (FromRow columns y, MonadIO io) => LibPQ.Row -- ^ row number -> K LibPQ.Result columns -- ^ result -> io y-getRow r (K result :: K LibPQ.Result columns) = liftBase $ do+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do numRows <- LibPQ.ntuples result when (numRows < r) $ throw $ ResultException $ "getRow: expected at least " <> pack (show r) <> "rows but only saw "@@ -547,13 +555,13 @@ -- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`, -- otherwise returning the row along with the next row number. nextRow- :: (FromRow columns y, MonadBase IO io)+ :: (FromRow columns y, MonadIO io) => LibPQ.Row -- ^ total number of rows -> K LibPQ.Result columns -- ^ result -> LibPQ.Row -- ^ row number -> io (Maybe (LibPQ.Row,y)) nextRow total (K result :: K LibPQ.Result columns) r- = liftBase $ if r >= total then return Nothing else do+ = liftIO $ if r >= total then return Nothing else do let len = fromIntegral (lengthSList (Proxy @columns)) row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1] case fromList row' of@@ -564,10 +572,10 @@ -- | Get all rows from a `LibPQ.Result`. getRows- :: (FromRow columns y, MonadBase IO io)+ :: (FromRow columns y, MonadIO io) => K LibPQ.Result columns -- ^ result -> io [y]-getRows (K result :: K LibPQ.Result columns) = liftBase $ do+getRows (K result :: K LibPQ.Result columns) = liftIO $ do let len = fromIntegral (lengthSList (Proxy @columns)) numRows <- LibPQ.ntuples result for [0 .. numRows - 1] $ \ r -> do@@ -580,10 +588,10 @@ -- | Get the first row if possible from a `LibPQ.Result`. firstRow- :: (FromRow columns y, MonadBase IO io)+ :: (FromRow columns y, MonadIO io) => K LibPQ.Result columns -- ^ result -> io (Maybe y)-firstRow (K result :: K LibPQ.Result columns) = liftBase $ do+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do numRows <- LibPQ.ntuples result if numRows <= 0 then return Nothing else do let len = fromIntegral (lengthSList (Proxy @columns))@@ -596,23 +604,23 @@ -- | Lifts actions on results from @LibPQ@. liftResult- :: MonadBase IO io+ :: MonadIO io => (LibPQ.Result -> IO x) -> K LibPQ.Result results -> io x-liftResult f (K result) = liftBase $ f result+liftResult f (K result) = liftIO $ f result -- | Returns the number of rows (tuples) in the query result.-ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row+ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row ntuples = liftResult LibPQ.ntuples -- | Returns the result status of the command.-resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus+resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus resultStatus = liftResult LibPQ.resultStatus -- | Returns the error message most recently generated by an operation -- on the connection. resultErrorMessage- :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString) resultErrorMessage = liftResult LibPQ.resultErrorMessage -- | Returns the error code most recently generated by an operation@@ -620,29 +628,29 @@ -- -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html resultErrorCode- :: MonadBase IO io+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString) resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate) --- | `Exception`s that can be thrown by Squeal.-data SquealException- = PQException+-- | the state of LibPQ+data PQState = PQState { sqlExecStatus :: LibPQ.ExecStatus , sqlStateCode :: Maybe ByteString -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html , sqlErrorMessage :: Maybe ByteString- }+ } deriving (Eq, Show)++-- | `Exception`s that can be thrown by Squeal.+data SquealException+ = PQException PQState | ResultException Text | ParseException Text deriving (Eq, Show) instance Exception SquealException -tryResult- :: MonadBase IO io- => LibPQ.Result- -> io ()-tryResult result = liftBase $ do+okResult_ :: MonadIO io => LibPQ.Result -> io ()+okResult_ result = liftIO $ do status <- LibPQ.resultStatus result case status of LibPQ.CommandOk -> return ()@@ -650,11 +658,16 @@ _ -> do stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate msg <- LibPQ.resultErrorMessage result- throw $ PQException status stateCode msg+ throw . PQException $ PQState status stateCode msg +-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`+-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.+okResult :: MonadIO io => K LibPQ.Result row -> io ()+okResult = okResult_ . unK+ -- | Catch `SquealException`s. catchSqueal- :: MonadBaseControl IO io+ :: MonadUnliftIO io => io a -> (SquealException -> io a) -- ^ handler -> io a@@ -662,7 +675,14 @@ -- | Handle `SquealException`s. handleSqueal- :: MonadBaseControl IO io+ :: MonadUnliftIO io => (SquealException -> io a) -- ^ handler -> io a -> io a handleSqueal = handle++-- | `Either` return a `SquealException` or a result.+trySqueal+ :: MonadUnliftIO io+ => io a+ -> io (Either SquealException a)+trySqueal = try
src/Squeal/PostgreSQL/Pool.hs view
@@ -12,6 +12,7 @@ DeriveFunctor , FlexibleContexts , FlexibleInstances+ , InstanceSigs , MultiParamTypeClasses , RankNTypes , ScopedTypeVariables@@ -26,51 +27,52 @@ , createConnectionPool , Pool , destroyAllResources- , PoolPQRun- , poolpqliftWith ) where -import Control.Monad.Base import Control.Monad.Trans-import Control.Monad.Trans.Control import Data.ByteString-import Data.Pool import Data.Time import Generics.SOP (K(..))+import UnliftIO (MonadUnliftIO (..))+import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource) +import qualified Control.Monad.Fail as Fail+ import Squeal.PostgreSQL.PQ import Squeal.PostgreSQL.Schema -{- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.+{- | `PoolPQ` @schemas@ should be a drop-in replacement for `PQ` @schemas schemas@. Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it. Here's a simplified example: -> type Schema = '[ "tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint2])]->-> someQuery :: Manipulation Schema '[ 'NotNull 'PGint2] '[]-> someQuery = insertRow #tab-> (Set (param @1) `As` #col :* Nil)-> OnConflictDoNothing (Returning Nil)->-> insertOne :: (MonadBaseControl IO m, MonadPQ Schema m) => m ()-> insertOne = void $ manipulateParams someQuery . Only $ (1 :: Int16)->-> insertOneInPool :: ByteString -> IO ()-> insertOneInPool connectionString = do-> pool <- createConnectionPool connectionString 1 0.5 10-> liftIO $ runPoolPQ (insertOne) pool-+>>> import Squeal.PostgreSQL+>>> :{+do+ let+ query :: Query_ (Public '[]) () (Only Char)+ query = values_ $ literal 'a' `as` #fromOnly+ session :: PoolPQ (Public '[]) IO Char+ session = do+ result <- runQuery query+ Just (Only chr) <- firstRow result+ return chr+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10+ chr <- runPoolPQ session pool+ destroyAllResources pool+ putChar chr+:}+a -}-newtype PoolPQ (schema :: SchemaType) m x =- PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }+newtype PoolPQ (schemas :: SchemasType) m x =+ PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x } deriving Functor -- | Create a striped pool of connections. -- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible. createConnectionPool- :: MonadBase IO io+ :: MonadUnliftIO io => ByteString -- ^ The passed string can be empty to use all default parameters, or it can -- contain one or more parameter settings separated by whitespace.@@ -86,12 +88,12 @@ -> Int -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1. -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.- -> io (Pool (K Connection schema))-createConnectionPool conninfo stripes idle maxResrc = liftBase $+ -> io (Pool (K Connection schemas))+createConnectionPool conninfo stripes idle maxResrc = createPool (connectdb conninfo) finish stripes idle maxResrc -- | `Applicative` instance for `PoolPQ`.-instance Monad m => Applicative (PoolPQ schema m) where+instance Monad m => Applicative (PoolPQ schemas m) where pure x = PoolPQ $ \ _ -> pure x PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do f' <- f pool@@ -99,55 +101,54 @@ return $ f' x' -- | `Monad` instance for `PoolPQ`.-instance Monad m => Monad (PoolPQ schema m) where+instance Monad m => Monad (PoolPQ schemas m) where return = pure PoolPQ x >>= f = PoolPQ $ \ pool -> do x' <- x pool runPoolPQ (f x') pool +-- | `Fail.MonadFail` instance for `PoolPQ`.+instance Monad m => Fail.MonadFail (PoolPQ schemas m) where+ fail = Fail.fail+ -- | `MonadTrans` instance for `PoolPQ`.-instance MonadTrans (PoolPQ schema) where+instance MonadTrans (PoolPQ schemas) where lift m = PoolPQ $ \ _pool -> m --- | `MonadBase` instance for `PoolPQ`.-instance MonadBase b m => MonadBase b (PoolPQ schema m) where- liftBase = lift . liftBase- -- | `MonadPQ` instance for `PoolPQ`.-instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where+instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where manipulateParams manipulation params = PoolPQ $ \ pool -> do withResource pool $ \ conn -> do- (K result :: K (K Result ys) schema) <- flip unPQ conn $+ (K result :: K (K Result ys) schemas) <- flip unPQ conn $ manipulateParams manipulation params return result traversePrepared manipulation params = PoolPQ $ \ pool -> withResource pool $ \ conn -> do- (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $+ (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $ traversePrepared manipulation params return result traversePrepared_ manipulation params = PoolPQ $ \ pool -> do withResource pool $ \ conn -> do- (_ :: K () schema) <- flip unPQ conn $+ (_ :: K () schemas) <- flip unPQ conn $ traversePrepared_ manipulation params return () liftPQ m = PoolPQ $ \ pool -> withResource pool $ \ conn -> do- (K result :: K result schema) <- flip unPQ conn $+ (K result :: K result schemas) <- flip unPQ conn $ liftPQ m return result --- | A snapshot of the state of a `PoolPQ` computation.-type PoolPQRun schema =- forall m x. Monad m => PoolPQ schema m x -> m x---- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.-poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a-poolpqliftWith f = PoolPQ $ \ pool ->- (f $ \ pq -> runPoolPQ pq pool)+-- | 'MonadIO' instance for 'PoolPQ'.+instance (MonadIO m)+ => MonadIO (PoolPQ schemas m) where+ liftIO = lift . liftIO --- | `MonadBaseControl` instance for `PoolPQ`.-instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where- type StM (PoolPQ schema m) x = StM m x- liftBaseWith f =- poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run- restoreM = PoolPQ . const . restoreM+-- | 'MonadUnliftIO' instance for 'PoolPQ'.+instance (MonadUnliftIO m)+ => MonadUnliftIO (PoolPQ schemas m) where+ withRunInIO+ :: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)+ -> PoolPQ schemas m b+ withRunInIO inner = PoolPQ $ \pool ->+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->+ inner (\poolpq -> run $ runPoolPQ poolpq pool)
src/Squeal/PostgreSQL/Query.hs view
@@ -1,1415 +1,1047 @@ {-| Module: Squeal.PostgreSQL.Query Description: Squeal queries-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--Squeal queries.--}--{-# LANGUAGE- ConstraintKinds- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , MultiParamTypeClasses- , OverloadedStrings- , StandaloneDeriving- , TypeFamilies- , TypeInType- , TypeOperators- , RankNTypes- , UndecidableInstances- #-}--module Squeal.PostgreSQL.Query- ( -- * Queries- Query (UnsafeQuery, renderQuery)- -- ** Select- , select- , selectDistinct- , selectStar- , selectDistinctStar- , selectDotStar- , selectDistinctDotStar- -- ** Values- , values- , values_- -- ** Set Operations- , union- , unionAll- , intersect- , intersectAll- , except- , exceptAll- -- ** With- , With (with)- , CommonTableExpression (..)- , renderCommonTableExpression- , renderCommonTableExpressions- -- ** Json- , jsonEach- , jsonbEach- , jsonEachAsText- , jsonbEachAsText- , jsonObjectKeys- , jsonbObjectKeys- , jsonPopulateRecord- , jsonbPopulateRecord- , jsonPopulateRecordSet- , jsonbPopulateRecordSet- , jsonToRecord- , jsonbToRecord- , jsonToRecordSet- , jsonbToRecordSet- -- * Table Expressions- , TableExpression (..)- , renderTableExpression- , from- , where_- , groupBy- , having- , orderBy- , limit- , offset- -- * From Clauses- , FromClause (..)- , table- , subquery- , view- , crossJoin- , innerJoin- , leftOuterJoin- , rightOuterJoin- , fullOuterJoin- -- * Grouping- , By (By1, By2)- , renderBy- , GroupByClause (NoGroups, Group)- , renderGroupByClause- , HavingClause (NoHaving, Having)- , renderHavingClause- -- * Sorting- , SortExpression (..)- , renderSortExpression- -- * Subquery Expressions- , in_- , rowIn- , eqAll- , rowEqAll- , eqAny- , rowEqAny- , neqAll- , rowNeqAll- , neqAny- , rowNeqAny- , allLt- , rowLtAll- , ltAny- , rowLtAny- , lteAll- , rowLteAll- , lteAny- , rowLteAny- , gtAll- , rowGtAll- , gtAny- , rowGtAny- , gteAll- , rowGteAll- , gteAny- , rowGteAny- ) where--import Control.DeepSeq-import Data.ByteString (ByteString)-import Data.String-import Data.Word-import Generics.SOP hiding (from)-import GHC.TypeLits--import qualified GHC.Generics as GHC--import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema--{- |-The process of retrieving or the command to retrieve data from a database-is called a `Query`. Let's see some examples of queries.--simple query:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]- '[]- '["col" ::: 'Null 'PGint4]- query = selectStar (from (table #tab))-in printSQL query-:}-SELECT * FROM "tab" AS "tab"--restricted query:-->>> :{-let- query :: Query- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]- '[]- '[ "sum" ::: 'NotNull 'PGint4- , "col1" ::: 'NotNull 'PGint4 ]- query =- select- ((#col1 + #col2) `as` #sum :* #col1)- ( from (table #tab)- & where_ (#col1 .> #col2)- & where_ (#col2 .> 0) )-in printSQL query-:}-SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))--subquery:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]- '[]- '["col" ::: 'Null 'PGint4]- query =- selectStar- (from (subquery (selectStar (from (table #tab)) `as` #sub)))-in printSQL query-:}-SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"--limits and offsets:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]- '[]- '["col" ::: 'Null 'PGint4]- query = selectStar- (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)-in printSQL query-:}-SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4--parameterized query:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]- '[ 'NotNull 'PGfloat8]- '["col" ::: 'NotNull 'PGfloat8]- query = selectStar- (from (table #tab) & where_ (#col .> param @1))-in printSQL query-:}-SELECT * FROM "tab" AS "tab" WHERE ("col" > ($1 :: float8))--aggregation query:-->>> :{-let- query :: Query- '[ "tab" ::: 'Table ('[] :=>- '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4- , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]- '[]- '[ "sum" ::: 'NotNull 'PGint4- , "col1" ::: 'NotNull 'PGint4 ]- query =- select (sum_ #col2 `as` #sum :* #col1)- ( from (table (#tab `as` #table1))- & groupBy #col1- & having (#col1 + sum_ #col2 .> 1) )-in printSQL query-:}-SELECT sum("col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum("col2")) > 1)--sorted query:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]- '[]- '["col" ::: 'Null 'PGint4]- query = selectStar- (from (table #tab) & orderBy [#col & AscNullsFirst])-in printSQL query-:}-SELECT * FROM "tab" AS "tab" ORDER BY "col" ASC NULLS FIRST--joins:-->>> :set -XFlexibleContexts->>> :{-let- query :: Query- '[ "orders" ::: 'Table (- '["pk_orders" ::: PrimaryKey '["id"]- ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]- ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>- '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4- , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4- , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4- , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4- ])- , "customers" ::: 'Table (- '["pk_customers" ::: PrimaryKey '["id"]] :=>- '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- ])- , "shippers" ::: 'Table (- '["pk_shippers" ::: PrimaryKey '["id"]] :=>- '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- ])- ]- '[]- '[ "order_price" ::: 'NotNull 'PGfloat4- , "customer_name" ::: 'NotNull 'PGtext- , "shipper_name" ::: 'NotNull 'PGtext- ]- query = select- ( #o ! #price `as` #order_price :*- #c ! #name `as` #customer_name :*- #s ! #name `as` #shipper_name )- ( from (table (#orders `as` #o)- & innerJoin (table (#customers `as` #c))- (#o ! #customer_id .== #c ! #id)- & innerJoin (table (#shippers `as` #s))- (#o ! #shipper_id .== #s ! #id)) )-in printSQL query-:}-SELECT "o"."price" AS "order_price", "c"."name" AS "customer_name", "s"."name" AS "shipper_name" 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")--self-join:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]- '[]- '["col" ::: 'Null 'PGint4]- query = selectDotStar #t1- (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))-in printSQL query-:}-SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"--value queries:-->>> :{-let- query :: Query '[] '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]- query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]-in printSQL query-:}-SELECT * FROM (VALUES (1, TRUE), (2, FALSE)) AS t ("foo", "bar")--set operations:-->>> :{-let- query :: Query- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]- '[]- '["col" ::: 'Null 'PGint4]- query =- selectStar (from (table #tab))- `unionAll`- selectStar (from (table #tab))-in printSQL query-:}-(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")--with queries:-->>> :{-let- query :: Query- '[ "t1" ::: 'View- '[ "c1" ::: 'NotNull 'PGtext- , "c2" ::: 'NotNull 'PGtext] ]- '[]- '[ "c1" ::: 'NotNull 'PGtext- , "c2" ::: 'NotNull 'PGtext ]- query = with (- selectStar (from (view #t1)) `as` #t2 :>>- selectStar (from (view #t2)) `as` #t3- ) (selectStar (from (view #t3)))-in printSQL query-:}-WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"--}-newtype Query- (schema :: SchemaType)- (params :: [NullityType])- (columns :: RowType)- = UnsafeQuery { renderQuery :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (Query schema params columns) where renderSQL = renderQuery---- | The results of two queries can be combined using the set operation--- `union`. Duplicate rows are eliminated.-union- :: Query schema params columns- -> Query schema params columns- -> Query schema params columns-q1 `union` q2 = UnsafeQuery $- parenthesized (renderQuery q1)- <+> "UNION"- <+> parenthesized (renderQuery q2)---- | The results of two queries can be combined using the set operation--- `unionAll`, the disjoint union. Duplicate rows are retained.-unionAll- :: Query schema params columns- -> Query schema params columns- -> Query schema params columns-q1 `unionAll` q2 = UnsafeQuery $- parenthesized (renderQuery q1)- <+> "UNION" <+> "ALL"- <+> parenthesized (renderQuery q2)---- | The results of two queries can be combined using the set operation--- `intersect`, the intersection. Duplicate rows are eliminated.-intersect- :: Query schema params columns- -> Query schema params columns- -> Query schema params columns-q1 `intersect` q2 = UnsafeQuery $- parenthesized (renderQuery q1)- <+> "INTERSECT"- <+> parenthesized (renderQuery q2)---- | The results of two queries can be combined using the set operation--- `intersectAll`, the intersection. Duplicate rows are retained.-intersectAll- :: Query schema params columns- -> Query schema params columns- -> Query schema params columns-q1 `intersectAll` q2 = UnsafeQuery $- parenthesized (renderQuery q1)- <+> "INTERSECT" <+> "ALL"- <+> parenthesized (renderQuery q2)---- | The results of two queries can be combined using the set operation--- `except`, the set difference. Duplicate rows are eliminated.-except- :: Query schema params columns- -> Query schema params columns- -> Query schema params columns-q1 `except` q2 = UnsafeQuery $- parenthesized (renderQuery q1)- <+> "EXCEPT"- <+> parenthesized (renderQuery q2)---- | The results of two queries can be combined using the set operation--- `exceptAll`, the set difference. Duplicate rows are retained.-exceptAll- :: Query schema params columns- -> Query schema params columns- -> Query schema params columns-q1 `exceptAll` q2 = UnsafeQuery $- parenthesized (renderQuery q1)- <+> "EXCEPT" <+> "ALL"- <+> parenthesized (renderQuery q2)--{------------------------------------------SELECT queries------------------------------------------}---- | the `TableExpression` in the `select` command constructs an intermediate--- virtual table by possibly combining tables, views, eliminating rows,--- grouping, etc. This table is finally passed on to processing by--- the select list. The select list determines which columns of--- the intermediate table are actually output.-select- :: SListI columns- => NP (Aliased (Expression schema from grouping params)) (column ': columns)- -- ^ select list- -> TableExpression schema params from grouping- -- ^ intermediate virtual table- -> Query schema params (column ': columns)-select list rels = UnsafeQuery $- "SELECT"- <+> renderCommaSeparated (renderAliasedAs renderExpression) list- <+> renderTableExpression rels---- | After the select list has been processed, the result table can--- be subject to the elimination of duplicate rows using `selectDistinct`.-selectDistinct- :: SListI columns- => NP (Aliased (Expression schema from 'Ungrouped params)) (column ': columns)- -- ^ select list- -> TableExpression schema params from 'Ungrouped- -- ^ intermediate virtual table- -> Query schema params (column ': columns)-selectDistinct list rels = UnsafeQuery $- "SELECT DISTINCT"- <+> renderCommaSeparated (renderAliasedAs renderExpression) list- <+> renderTableExpression rels---- | The simplest kind of query is `selectStar` which emits all columns--- that the table expression produces.-selectStar- :: HasUnique table from columns- => TableExpression schema params from 'Ungrouped- -- ^ intermediate virtual table- -> Query schema params columns-selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels---- | A `selectDistinctStar` emits all columns that the table expression--- produces and eliminates duplicate rows.-selectDistinctStar- :: HasUnique table from columns- => TableExpression schema params from 'Ungrouped- -- ^ intermediate virtual table- -> Query schema params columns-selectDistinctStar rels = UnsafeQuery $- "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels---- | When working with multiple tables, it can also be useful to ask--- for all the columns of a particular table, using `selectDotStar`.-selectDotStar- :: Has table from columns- => Alias table- -- ^ particular virtual subtable- -> TableExpression schema params from 'Ungrouped- -- ^ intermediate virtual table- -> Query schema params columns-selectDotStar rel tab = UnsafeQuery $- "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression tab---- | A `selectDistinctDotStar` asks for all the columns of a particular table,--- and eliminates duplicate rows.-selectDistinctDotStar- :: Has table from columns- => Alias table- -- ^ particular virtual table- -> TableExpression schema params from 'Ungrouped- -- ^ intermediate virtual table- -> Query schema params columns-selectDistinctDotStar rel tab = UnsafeQuery $- "SELECT DISTINCT" <+> renderAlias rel <> ".*"- <+> renderTableExpression tab---- | `values` computes a row value or set of row values--- specified by value expressions. It is most commonly used--- to generate a “constant table” within a larger command,--- but it can be used on its own.------ >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]--- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query '[] '[] Row--- >>> printSQL query--- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")-values- :: SListI cols- => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols- -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols]- -- ^ When more than one row is specified, all the rows must- -- must have the same number of elements- -> Query schema params cols-values rw rws = UnsafeQuery $ "SELECT * FROM"- <+> parenthesized (- "VALUES"- <+> commaSeparated- ( parenthesized- . renderCommaSeparated renderValuePart <$> rw:rws )- ) <+> "AS t"- <+> parenthesized (renderCommaSeparated renderAliasPart rw)- where- renderAliasPart, renderValuePart- :: Aliased (Expression schema '[] 'Ungrouped params) ty -> ByteString- renderAliasPart (_ `As` name) = renderAlias name- renderValuePart (value `As` _) = renderExpression value---- | `values_` computes a row value or set of row values--- specified by value expressions.-values_- :: SListI cols- => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols- -- ^ one row of values- -> Query schema params cols-values_ rw = values rw []--{------------------------------------------Table Expressions------------------------------------------}---- | 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--- 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- (schema :: SchemaType)- (params :: [NullityType])- (from :: FromType)- (grouping :: Grouping)- = TableExpression- { fromClause :: FromClause schema params from- -- ^ A table reference that can be a table name, or a derived table such- -- as a subquery, a @JOIN@ construct, or complex combinations of these.- , whereClause :: [Condition schema from 'Ungrouped params]- -- ^ optional search coditions, combined with `.&&`. After the processing- -- of the `fromClause` is done, each row of the derived virtual table- -- is checked against the search condition. If the result of the- -- condition is true, the row is kept in the output table,- -- otherwise it is discarded. The search condition typically references- -- at least one column of the table generated in the `fromClause`;- -- this is not required, but otherwise the WHERE clause will- -- be fairly useless.- , groupByClause :: GroupByClause from grouping- -- ^ The `groupByClause` is used to group together those rows in a table- -- that have the same values in all the columns listed. The order in which- -- the columns are listed does not matter. The effect is to combine each- -- set of rows having common values into one group row that represents all- -- rows in the group. This is done to eliminate redundancy in the output- -- and/or compute aggregates that apply to these groups.- , havingClause :: HavingClause schema from grouping params- -- ^ If a table has been grouped using `groupBy`, but only certain groups- -- are of interest, the `havingClause` can be used, much like a- -- `whereClause`, to eliminate groups from the result. Expressions in the- -- `havingClause` can refer both to grouped expressions and to ungrouped- -- expressions (which necessarily involve an aggregate function).- , orderByClause :: [SortExpression schema from grouping params]- -- ^ The `orderByClause` is for optional sorting. When more than one- -- `SortExpression` is specified, the later (right) values are used to sort- -- rows that are equal according to the earlier (left) values.- , limitClause :: [Word64]- -- ^ The `limitClause` is combined with `min` to give a limit count- -- if nonempty. If a limit count is given, no more than that many rows- -- will be returned (but possibly fewer, if the query itself yields- -- fewer rows).- , offsetClause :: [Word64]- -- ^ The `offsetClause` is combined with `+` to give an offset count- -- 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.- }---- | Render a `TableExpression`-renderTableExpression- :: TableExpression schema params from grouping- -> ByteString-renderTableExpression- (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat- [ "FROM ", renderFromClause frm'- , renderWheres whs'- , renderGroupByClause grps'- , renderHavingClause hvs'- , renderOrderByClause srts'- , renderLimits lims'- , renderOffsets offs'- ]- where- renderWheres = \case- [] -> ""- wh:[] -> " WHERE" <+> renderExpression wh- wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)- renderOrderByClause = \case- [] -> ""- srts -> " ORDER BY"- <+> commaSeparated (renderSortExpression <$> srts)- renderLimits = \case- [] -> ""- lims -> " LIMIT" <+> fromString (show (minimum lims))- renderOffsets = \case- [] -> ""- offs -> " OFFSET" <+> fromString (show (sum offs))---- | 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,--- or complex combinations of these. A `from` may be transformed by `where_`,--- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator--- to match the left-to-right sequencing of their placement in SQL.-from- :: FromClause schema params from -- ^ table reference- -> TableExpression schema params from 'Ungrouped-from rels = TableExpression rels [] NoGroups NoHaving [] [] []---- | A `where_` is an endomorphism of `TableExpression`s which adds a--- search condition to the `whereClause`.-where_- :: Condition schema from 'Ungrouped params -- ^ filtering condition- -> TableExpression schema params from grouping- -> TableExpression schema params from grouping-where_ wh rels = rels {whereClause = wh : whereClause rels}---- | A `groupBy` is a transformation of `TableExpression`s which switches--- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform--- a "grand total" aggregation query.-groupBy- :: SListI bys- => NP (By from) bys -- ^ grouped columns- -> TableExpression schema params from 'Ungrouped- -> TableExpression schema params from ('Grouped bys)-groupBy bys rels = TableExpression- { fromClause = fromClause rels- , whereClause = whereClause rels- , groupByClause = Group bys- , havingClause = Having []- , orderByClause = []- , limitClause = limitClause rels- , offsetClause = offsetClause rels- }---- | A `having` is an endomorphism of `TableExpression`s which adds a--- search condition to the `havingClause`.-having- :: Condition schema from ('Grouped bys) params -- ^ having condition- -> TableExpression schema params from ('Grouped bys)- -> TableExpression schema params from ('Grouped bys)-having hv rels = rels- { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }---- | An `orderBy` is an endomorphism of `TableExpression`s which appends an--- ordering to the right of the `orderByClause`.-orderBy- :: [SortExpression schema from grouping params] -- ^ sort expressions- -> TableExpression schema params from grouping- -> TableExpression schema params from grouping-orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}---- | A `limit` is an endomorphism of `TableExpression`s which adds to the--- `limitClause`.-limit- :: Word64 -- ^ limit parameter- -> TableExpression schema params from grouping- -> TableExpression schema params from grouping-limit lim rels = rels {limitClause = lim : limitClause rels}---- | An `offset` is an endomorphism of `TableExpression`s which adds to the--- `offsetClause`.-offset- :: Word64 -- ^ offset parameter- -> TableExpression schema params from grouping- -> TableExpression schema params from grouping-offset off rels = rels {offsetClause = off : offsetClause rels}--{------------------------------------------JSON stuff------------------------------------------}--unsafeSetOfFunction- :: ByteString- -> Expression schema '[] 'Ungrouped params ty- -> Query schema params row-unsafeSetOfFunction fun expr = UnsafeQuery $- "SELECT * FROM " <> fun <> "(" <> renderExpression expr <> ")"---- | Expands the outermost JSON object into a set of key/value pairs.-jsonEach- :: Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object- -> Query schema params- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]-jsonEach = unsafeSetOfFunction "json_each"---- | Expands the outermost binary JSON object into a set of key/value pairs.-jsonbEach- :: Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object- -> Query schema params- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjsonb]-jsonbEach = unsafeSetOfFunction "jsonb_each"---- | Expands the outermost JSON object into a set of key/value pairs.-jsonEachAsText- :: Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object- -> Query schema params- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]-jsonEachAsText = unsafeSetOfFunction "json_each_text"---- | Expands the outermost binary JSON object into a set of key/value pairs.-jsonbEachAsText- :: Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object- -> Query schema params- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]-jsonbEachAsText = unsafeSetOfFunction "jsonb_each_text"---- | Returns set of keys in the outermost JSON object.-jsonObjectKeys- :: Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object- -> Query schema params '["json_object_keys" ::: 'NotNull 'PGtext]-jsonObjectKeys = unsafeSetOfFunction "json_object_keys"---- | Returns set of keys in the outermost JSON object.-jsonbObjectKeys- :: Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object- -> Query schema params '["jsonb_object_keys" ::: 'NotNull 'PGtext]-jsonbObjectKeys = unsafeSetOfFunction "jsonb_object_keys"--unsafePopulateFunction- :: ByteString- -> TypeExpression schema (nullity ('PGcomposite row))- -> Expression schema '[] 'Ungrouped params ty- -> Query schema params row-unsafePopulateFunction fun ty expr = UnsafeQuery $- "SELECT * FROM " <> fun <> "("- <> "null::" <> renderTypeExpression ty <> ", "- <> renderExpression expr <> ")"---- | Expands the JSON expression to a row whose columns match the record--- type defined by the given table.-jsonPopulateRecord- :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type- -> Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object- -> Query schema params row-jsonPopulateRecord = unsafePopulateFunction "json_populate_record"---- | Expands the binary JSON expression to a row whose columns match the record--- type defined by the given table.-jsonbPopulateRecord- :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type- -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object- -> Query schema params row-jsonbPopulateRecord = unsafePopulateFunction "jsonb_populate_record"---- | Expands the outermost array of objects in the given JSON expression to a--- set of rows whose columns match the record type defined by the given table.-jsonPopulateRecordSet- :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type- -> Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array- -> Query schema params row-jsonPopulateRecordSet = unsafePopulateFunction "json_populate_record_set"---- | Expands the outermost array of objects in the given binary JSON expression--- to a set of rows whose columns match the record type defined by the given--- table.-jsonbPopulateRecordSet- :: TypeExpression schema (nullity ('PGcomposite row)) -- ^ row type- -> Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array- -> Query schema params row-jsonbPopulateRecordSet = unsafePopulateFunction "jsonb_populate_record_set"--unsafeRecordFunction- :: (SListI record, json `In` PGJsonType)- => ByteString- -> Expression schema '[] 'Ungrouped params (nullity json)- -> NP (Aliased (TypeExpression schema)) record- -> Query schema params record-unsafeRecordFunction fun expr types = UnsafeQuery $- "SELECT * FROM " <> fun <> "("- <> renderExpression expr <> ")"- <+> "AS" <+> "x" <> parenthesized (renderCommaSeparated renderTy types)- where- renderTy :: Aliased (TypeExpression schema) ty -> ByteString- renderTy (ty `As` alias) =- renderAlias alias <+> renderTypeExpression ty---- | Builds an arbitrary record from a JSON object.-jsonToRecord- :: SListI record- => Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json object- -> NP (Aliased (TypeExpression schema)) record -- ^ record types- -> Query schema params record-jsonToRecord = unsafeRecordFunction "json_to_record"---- | Builds an arbitrary record from a binary JSON object.-jsonbToRecord- :: SListI record- => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb object- -> NP (Aliased (TypeExpression schema)) record -- ^ record types- -> Query schema params record-jsonbToRecord = unsafeRecordFunction "jsonb_to_record"---- | Builds an arbitrary set of records from a JSON array of objects.-jsonToRecordSet- :: SListI record- => Expression schema '[] 'Ungrouped params (nullity 'PGjson) -- ^ json array- -> NP (Aliased (TypeExpression schema)) record -- ^ record types- -> Query schema params record-jsonToRecordSet = unsafeRecordFunction "json_to_record_set"---- | Builds an arbitrary set of records from a binary JSON array of objects.-jsonbToRecordSet- :: SListI record- => Expression schema '[] 'Ungrouped params (nullity 'PGjsonb) -- ^ jsonb array- -> NP (Aliased (TypeExpression schema)) record -- ^ record types- -> Query schema params record-jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"--{------------------------------------------FROM clauses------------------------------------------}--{- |-A `FromClause` can be a table name, or a derived table such-as a subquery, a @JOIN@ construct, or complex combinations of these.--}-newtype FromClause schema params from- = UnsafeFromClause { renderFromClause :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)---- | A real `table` is a table from the schema.-table- :: Has tab schema ('Table table)- => Aliased Alias (alias ::: tab)- -> FromClause schema params '[alias ::: TableToRow table]-table (tab `As` alias) = UnsafeFromClause $- renderAlias tab <+> "AS" <+> renderAlias alias---- | `subquery` derives a table from a `Query`.-subquery- :: Aliased (Query schema params) rel- -> FromClause schema params '[rel]-subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)---- | `view` derives a table from a `View`.-view- :: Has view schema ('View row)- => Aliased Alias (alias ::: view)- -> FromClause schema params '[alias ::: row]-view (vw `As` alias) = UnsafeFromClause $- renderAlias vw <+> "AS" <+> renderAlias alias--{- | @left & crossJoin right@. For every possible combination of rows from- @left@ and @right@ (i.e., a Cartesian product), the joined table will contain- a row consisting of all columns in @left@ followed by all columns in @right@.- If the tables have @n@ and @m@ rows respectively, the joined table will- have @n * m@ rows.--}-crossJoin- :: FromClause schema params right- -- ^ right- -> FromClause schema params left- -- ^ left- -> FromClause schema params (Join left right)-crossJoin right left = UnsafeFromClause $- renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right--{- | @left & innerJoin right on@. The joined table is filtered by-the @on@ condition.--}-innerJoin- :: FromClause schema params right- -- ^ right- -> Condition schema (Join left right) 'Ungrouped params- -- ^ @on@ condition- -> FromClause schema params left- -- ^ left- -> FromClause schema params (Join left right)-innerJoin right on left = UnsafeFromClause $- renderFromClause left <+> "INNER JOIN" <+> renderFromClause right- <+> "ON" <+> renderExpression on--{- | @left & leftOuterJoin right on@. First, an inner join is performed.- Then, for each row in @left@ that does not satisfy the @on@ condition with- any row in @right@, a joined row is added with null values in columns of @right@.- Thus, the joined table always has at least one row for each row in @left@.--}-leftOuterJoin- :: FromClause schema params right- -- ^ right- -> Condition schema (Join left right) 'Ungrouped params- -- ^ @on@ condition- -> FromClause schema params left- -- ^ left- -> FromClause schema params (Join left (NullifyFrom right))-leftOuterJoin right on left = UnsafeFromClause $- renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right- <+> "ON" <+> renderExpression on--{- | @left & rightOuterJoin right on@. First, an inner join is performed.- Then, for each row in @right@ that does not satisfy the @on@ condition with- any row in @left@, a joined row is added with null values in columns of @left@.- This is the converse of a left join: the result table will always- have a row for each row in @right@.--}-rightOuterJoin- :: FromClause schema params right- -- ^ right- -> Condition schema (Join left right) 'Ungrouped params- -- ^ @on@ condition- -> FromClause schema params left- -- ^ left- -> FromClause schema params (Join (NullifyFrom left) right)-rightOuterJoin right on left = UnsafeFromClause $- renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right- <+> "ON" <+> renderExpression on--{- | @left & fullOuterJoin right on@. First, an inner join is performed.- Then, for each row in @left@ that does not satisfy the @on@ condition with- any row in @right@, a joined row is added with null values in columns of @right@.- Also, for each row of @right@ that does not satisfy the join condition- with any row in @left@, a joined row with null values in the columns of @left@- is added.--}-fullOuterJoin- :: FromClause schema params right- -- ^ right- -> Condition schema (Join left right) 'Ungrouped params- -- ^ @on@ condition- -> FromClause schema params left- -- ^ left- -> FromClause schema params- (Join (NullifyFrom left) (NullifyFrom right))-fullOuterJoin right on left = UnsafeFromClause $- renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right- <+> "ON" <+> renderExpression on--{------------------------------------------Grouping------------------------------------------}---- | `By`s are used in `group` to reference a list of columns which are then--- used to group together those rows in a table that have the same values--- in all the columns listed. @By \#col@ will reference an unambiguous--- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table--- qualified column @tab.col@.-data By- (from :: FromType)- (by :: (Symbol,Symbol)) where- By1- :: (HasUnique table from columns, Has column columns ty)- => Alias column- -> By from '(table, column)- By2- :: (Has table from columns, Has column columns ty)- => Alias table- -> Alias column- -> By from '(table, column)-deriving instance Show (By from by)-deriving instance Eq (By from by)-deriving instance Ord (By from by)--instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))- => IsLabel col (By rels by) where fromLabel = By1 fromLabel-instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])- => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil-instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))- => IsQualified rel col (By rels by) where (!) = By2-instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])- => IsQualified rel col (NP (By rels) bys) where- rel ! col = By2 rel col :* Nil---- | Renders a `By`.-renderBy :: By from by -> ByteString-renderBy = \case- By1 column -> renderAlias column- By2 rel column -> renderAlias rel <> "." <> renderAlias column---- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.--- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.--- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be--- done on @NoGroups@ while all output `Expression`s must be aggregated--- in @Group Nil@. In general, all output `Expression`s in the--- complement of @bys@ must be aggregated in @Group bys@.-data GroupByClause from grouping where- NoGroups :: GroupByClause from 'Ungrouped- Group- :: SListI bys- => NP (By from) bys- -> GroupByClause from ('Grouped bys)---- | Renders a `GroupByClause`.-renderGroupByClause :: GroupByClause from grouping -> ByteString-renderGroupByClause = \case- NoGroups -> ""- Group Nil -> ""- Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys---- | A `HavingClause` is used to eliminate groups that are not of interest.--- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`--- `TableExpression` must use `Having` whose conditions are combined with--- `.&&`.-data HavingClause schema from grouping params where- NoHaving :: HavingClause schema from 'Ungrouped params- Having- :: [Condition schema from ('Grouped bys) params]- -> HavingClause schema from ('Grouped bys) params-deriving instance Show (HavingClause schema from grouping params)-deriving instance Eq (HavingClause schema from grouping params)-deriving instance Ord (HavingClause schema from grouping params)---- | Render a `HavingClause`.-renderHavingClause :: HavingClause schema from grouping params -> ByteString-renderHavingClause = \case- NoHaving -> ""- Having [] -> ""- Having conditions ->- " HAVING" <+> commaSeparated (renderExpression <$> conditions)--{------------------------------------------Sorting------------------------------------------}---- | `SortExpression`s are used by `sortBy` to optionally sort the results--- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result--- column to ascending or descending. Ascending order puts smaller values--- first, where "smaller" is defined in terms of the `.<` operator. Similarly,--- descending order is determined with the `.>` operator. `AscNullsFirst`,--- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to--- determine whether nulls appear before or after non-null values in the sort--- ordering of a `Null` result column.-data SortExpression schema from grouping params where- Asc- :: Expression schema from grouping params ('NotNull ty)- -> SortExpression schema from grouping params- Desc- :: Expression schema from grouping params ('NotNull ty)- -> SortExpression schema from grouping params- AscNullsFirst- :: Expression schema from grouping params ('Null ty)- -> SortExpression schema from grouping params- AscNullsLast- :: Expression schema from grouping params ('Null ty)- -> SortExpression schema from grouping params- DescNullsFirst- :: Expression schema from grouping params ('Null ty)- -> SortExpression schema from grouping params- DescNullsLast- :: Expression schema from grouping params ('Null ty)- -> SortExpression schema from grouping params-deriving instance Show (SortExpression schema from grouping params)---- | Render a `SortExpression`.-renderSortExpression :: SortExpression schema from grouping params -> ByteString-renderSortExpression = \case- Asc expression -> renderExpression expression <+> "ASC"- Desc expression -> renderExpression expression <+> "DESC"- AscNullsFirst expression -> renderExpression expression- <+> "ASC NULLS FIRST"- DescNullsFirst expression -> renderExpression expression- <+> "DESC NULLS FIRST"- AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"- DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"--unsafeSubqueryExpression- :: ByteString- -> Expression schema from grp params ty- -> Query schema params '[alias ::: ty]- -> Expression schema from grp params (nullity 'PGbool)-unsafeSubqueryExpression op x q = UnsafeExpression $- renderExpression x <+> op <+> parenthesized (renderQuery q)--unsafeRowSubqueryExpression- :: SListI row- => ByteString- -> NP (Aliased (Expression schema from grp params)) row- -> Query schema params row- -> Expression schema from grp params (nullity 'PGbool)-unsafeRowSubqueryExpression op xs q = UnsafeExpression $- renderExpression (row xs) <+> op <+> parenthesized (renderQuery q)---- | The right-hand side is a sub`Query`, which must return exactly one column.--- The left-hand expression is evaluated and compared to each row of the--- sub`Query` result. The result of `in_` is `true` if any equal subquery row is found.--- The result is `false` if no equal row is found--- (including the case where the subquery returns no rows).------ >>> printSQL $ true `in_` values_ (true `as` #foo)--- TRUE IN (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-in_- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-in_ = unsafeSubqueryExpression "IN"--{- | The left-hand side of this form of `rowIn` is a row constructor.-The right-hand side is a sub`Query`,-which must return exactly as many columns as-there are expressions in the left-hand row.-The left-hand expressions are evaluated and compared row-wise to each row-of the subquery result. The result of `rowIn`-is `true` if any equal subquery row is found.-The result is `false` if no equal row is found-(including the case where the subquery returns no rows).-->>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]->>> printSQL $ myRow `rowIn` values_ myRow-ROW(1, FALSE) IN (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))--}-rowIn- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowIn = unsafeRowSubqueryExpression "IN"---- | >>> printSQL $ true `eqAll` values_ (true `as` #foo)--- TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-eqAll- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-eqAll = unsafeSubqueryExpression "= ALL"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowEqAll` values_ myRow--- ROW(1, FALSE) = ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowEqAll- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowEqAll = unsafeRowSubqueryExpression "= ALL"---- | >>> printSQL $ true `eqAny` values_ (true `as` #foo)--- TRUE = ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-eqAny- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-eqAny = unsafeSubqueryExpression "= ANY"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowEqAny` values_ myRow--- ROW(1, FALSE) = ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowEqAny- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowEqAny = unsafeRowSubqueryExpression "= ANY"---- | >>> printSQL $ true `neqAll` values_ (true `as` #foo)--- TRUE <> ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-neqAll- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-neqAll = unsafeSubqueryExpression "<> ALL"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowNeqAll` values_ myRow--- ROW(1, FALSE) <> ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowNeqAll- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowNeqAll = unsafeRowSubqueryExpression "<> ALL"---- | >>> printSQL $ true `neqAny` values_ (true `as` #foo)--- TRUE <> ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-neqAny- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-neqAny = unsafeSubqueryExpression "<> ANY"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowNeqAny` values_ myRow--- ROW(1, FALSE) <> ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowNeqAny- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowNeqAny = unsafeRowSubqueryExpression "<> ANY"---- | >>> printSQL $ true `allLt` values_ (true `as` #foo)--- TRUE ALL < (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-allLt- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-allLt = unsafeSubqueryExpression "ALL <"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowLtAll` values_ myRow--- ROW(1, FALSE) ALL < (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowLtAll- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowLtAll = unsafeRowSubqueryExpression "ALL <"---- | >>> printSQL $ true `ltAny` values_ (true `as` #foo)--- TRUE ANY < (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-ltAny- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-ltAny = unsafeSubqueryExpression "ANY <"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowLtAll` values_ myRow--- ROW(1, FALSE) ALL < (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowLtAny- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowLtAny = unsafeRowSubqueryExpression "ANY <"---- | >>> printSQL $ true `lteAll` values_ (true `as` #foo)--- TRUE <= ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-lteAll- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-lteAll = unsafeSubqueryExpression "<= ALL"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowLteAll` values_ myRow--- ROW(1, FALSE) <= ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowLteAll- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowLteAll = unsafeRowSubqueryExpression "<= ALL"---- | >>> printSQL $ true `lteAny` values_ (true `as` #foo)--- TRUE <= ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-lteAny- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-lteAny = unsafeSubqueryExpression "<= ANY"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowLteAny` values_ myRow--- ROW(1, FALSE) <= ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowLteAny- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowLteAny = unsafeRowSubqueryExpression "<= ANY"---- | >>> printSQL $ true `gtAll` values_ (true `as` #foo)--- TRUE > ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-gtAll- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-gtAll = unsafeSubqueryExpression "> ALL"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowGtAll` values_ myRow--- ROW(1, FALSE) > ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowGtAll- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowGtAll = unsafeRowSubqueryExpression "> ALL"---- | >>> printSQL $ true `gtAny` values_ (true `as` #foo)--- TRUE > ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-gtAny- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-gtAny = unsafeSubqueryExpression "> ANY"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowGtAny` values_ myRow--- ROW(1, FALSE) > ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowGtAny- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowGtAny = unsafeRowSubqueryExpression "> ANY"---- | >>> printSQL $ true `gteAll` values_ (true `as` #foo)--- TRUE >= ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-gteAll- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-gteAll = unsafeSubqueryExpression ">= ALL"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowGteAll` values_ myRow--- ROW(1, FALSE) >= ALL (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowGteAll- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowGteAll = unsafeRowSubqueryExpression ">= ALL"---- | >>> printSQL $ true `gteAny` values_ (true `as` #foo)--- TRUE >= ANY (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))-gteAny- :: Expression schema from grp params ty -- ^ expression- -> Query schema params '[alias ::: ty] -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-gteAny = unsafeSubqueryExpression ">= ANY"---- | >>> let myRow = 1 `as` #foo :* false `as` #bar :: NP (Aliased (Expression '[] '[] 'Ungrouped '[])) '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]--- >>> printSQL $ myRow `rowGteAny` values_ myRow--- ROW(1, FALSE) >= ANY (SELECT * FROM (VALUES (1, FALSE)) AS t ("foo", "bar"))-rowGteAny- :: SListI row- => NP (Aliased (Expression schema from grp params)) row -- ^ row constructor- -> Query schema params row -- ^ subquery- -> Expression schema from grp params (nullity 'PGbool)-rowGteAny = unsafeRowSubqueryExpression ">= ANY"---- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.-data CommonTableExpression statement- (params :: [NullityType])- (schema0 :: SchemaType)- (schema1 :: SchemaType) where- CommonTableExpression- :: Aliased (statement schema params) (alias ::: cte)- -> CommonTableExpression- statement params schema (alias ::: 'View cte ': schema)-instance (KnownSymbol alias, schema1 ~ (alias ::: 'View cte ': schema))- => Aliasable alias- (statement schema params cte)- (CommonTableExpression statement params schema schema1) where- statement `as` alias = CommonTableExpression (statement `as` alias)-instance (KnownSymbol alias, schema1 ~ (alias ::: 'View cte ': schema))- => Aliasable alias (statement schema params cte)- (AlignedList (CommonTableExpression statement params) schema schema1) where- statement `as` alias = single (statement `as` alias)---- | render a `CommonTableExpression`.-renderCommonTableExpression- :: (forall sch ps row. statement ps sch row -> ByteString) -- ^ render statement- -> CommonTableExpression statement params schema0 schema1 -> ByteString-renderCommonTableExpression renderStatement- (CommonTableExpression (statement `As` alias)) =- renderAlias alias <+> "AS" <+> parenthesized (renderStatement statement)---- | render a non-empty `AlignedList` of `CommonTableExpression`s.-renderCommonTableExpressions- :: (forall sch ps row. statement ps sch row -> ByteString) -- ^ render statement- -> CommonTableExpression statement params schema0 schema1- -> AlignedList (CommonTableExpression statement params) schema1 schema2- -> ByteString-renderCommonTableExpressions renderStatement cte ctes =- renderCommonTableExpression renderStatement cte <> case ctes of- Done -> ""- cte' :>> ctes' -> "," <+>- renderCommonTableExpressions renderStatement cte' ctes'---- | `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.-class With statement where- with- :: AlignedList (CommonTableExpression statement params) schema0 schema1- -- ^ common table expressions- -> statement schema1 params row- -- ^ larger query- -> statement schema0 params row-instance With Query where- with Done query = query- with (cte :>> ctes) query = UnsafeQuery $- "WITH" <+> renderCommonTableExpressions renderQuery cte ctes- <+> renderQuery query+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal queries.+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query+ ( -- * Queries+ Query_+ , Query (..)+ -- ** Select+ , select+ , select_+ , selectDistinct+ , selectDistinct_+ , Selection (..)+ -- ** Values+ , values+ , values_+ -- ** Set Operations+ , union+ , unionAll+ , intersect+ , intersectAll+ , except+ , exceptAll+ -- ** With+ , With (..)+ , CommonTableExpression (..)+ , withRecursive+ -- * Table Expressions+ , TableExpression (..)+ , from+ , where_+ , groupBy+ , having+ , limit+ , offset+ -- * From Clauses+ , FromClause (..)+ , table+ , subquery+ , view+ , common+ , crossJoin+ , innerJoin+ , leftOuterJoin+ , rightOuterJoin+ , fullOuterJoin+ -- * Grouping+ , By (..)+ , GroupByClause (..)+ , HavingClause (..)+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.Kind (Type)+import Data.String+import Data.Word+import Generics.SOP hiding (from)+import GHC.TypeLits++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Sort+import Squeal.PostgreSQL.Expression.Window+import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.PG+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Schema++-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> import Data.Int (Int32, Int64)+-- >>> import Data.Monoid (Sum (..))+-- >>> import Data.Text (Text)+-- >>> import qualified Generics.SOP as SOP++{- |+The process of retrieving or the command to retrieve data from+a database is called a `Query`.++The general `Query` type is parameterized by++* @outer :: FromType@ - outer scope for a correlated subquery,+* @commons :: FromType@ - scope for all `common` table expressions,+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,+* @row :: RowType@ - return type of the `Query`.+-}+newtype Query+ (outer :: FromType)+ (commons :: FromType)+ (schemas :: SchemasType)+ (params :: [NullityType])+ (row :: RowType)+ = UnsafeQuery { renderQuery :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery++{- |+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,+against which the query is type-checked, an input @parameters@ Haskell `Type`,+and an ouput row Haskell `Type`.++A top-level query can be run+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@+using `Squeal.PostgreSQL.PQ.runQuery`.++Generally, @parameters@ 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 or a generalized record using tuples of `P` types and normal Haskell+records, 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)+:}++simple query:++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query = select Star (from (table #tab))+in printSQL query+:}+SELECT * FROM "tab" AS "tab"++restricted query:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query =+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)+ ( from (table #tab)+ & where_ (#col1 .> #col2)+ & where_ (#col2 .> 0) )+in printSQL query+:}+SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))++subquery:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))+in printSQL query+:}+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"++limits and offsets:++>>> :{+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+:}+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4++parameterized query:++>>> :{+let+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)+ query = select Star (from (table #tab) & where_ (#col1 .> param @1))+in printSQL query+:}+SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))++aggregation query:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query =+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)+ ( from (table (#tab `as` #table1))+ & groupBy #col1+ & having (#col1 + (fromNull 0 (sum_ (Distinct #col2))) .> 1) )+in printSQL query+:}+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + COALESCE(sum(DISTINCT "col2"), 0)) > 1)++sorted query:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query = select Star (from (table #tab) & orderBy [#col1 & Asc])+in printSQL query+:}+SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC++joins:++>>> :{+type OrdersColumns =+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]+:}++>>> :{+type OrdersConstraints =+ '["pk_orders" ::: PrimaryKey '["id"]+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]+:}++>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]+>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]+>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]+>>> :{+type OrdersSchema =+ '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]+:}++>>> :{+data Order = Order+ { price :: Float+ , customerName :: Text+ , shipperName :: Text+ } deriving GHC.Generic+instance SOP.Generic Order+instance SOP.HasDatatypeInfo Order+:}++>>> :{+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)+ & innerJoin (table (#customers `as` #c))+ (#o ! #customer_id .== #c ! #id)+ & innerJoin (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 "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")++self-join:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query = select+ (#t1 & DotStar)+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))+in printSQL query+:}+SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"++value queries:++>>> :{+let+ query :: Query_ schemas () (Row String Bool)+ query = values+ ("true" `as` #col1 :* true `as` #col2)+ ["false" `as` #col1 :* false `as` #col2]+in printSQL query+:}+SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")++set operations:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))+in printSQL query+:}+(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")++with queries:++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int32)+ query = with (+ select Star (from (table #tab)) `as` #cte1 :>>+ select Star (from (common #cte1)) `as` #cte2+ ) (select Star (from (common #cte2)))+in printSQL query+:}+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++window function queries++>>> :{+let+ query :: Query_ (Public Schema) () (Row Int32 Int64)+ query = select+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))+ (from (table #tab))+in printSQL query+:}+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"++correlated subqueries++>>> :{+let+ query :: Query_ (Public Schema) () (Only Int32)+ query =+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))+ & where_ (exists (+ select Star (from (table (#tab `as` #t2))+ & where_ (#t2 ! #col2 .== #t1 ! #col1)))))+in printSQL query+:}+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))++-}+type family Query_+ (schemas :: SchemasType)+ (parameters :: Type)+ (row :: Type) where+ Query_ schemas params row =+ Query '[] '[] schemas (TuplePG params) (RowPG row)++-- | The results of two queries can be combined using the set operation+-- `union`. Duplicate rows are eliminated.+union+ :: Query outer commons schemas params columns+ -> Query outer commons schemas params columns+ -> Query outer commons schemas params columns+q1 `union` q2 = UnsafeQuery $+ parenthesized (renderSQL q1)+ <+> "UNION"+ <+> parenthesized (renderSQL q2)++-- | The results of two queries can be combined using the set operation+-- `unionAll`, the disjoint union. Duplicate rows are retained.+unionAll+ :: Query outer commons schemas params columns+ -> Query outer commons schemas params columns+ -> Query outer commons schemas params columns+q1 `unionAll` q2 = UnsafeQuery $+ parenthesized (renderSQL q1)+ <+> "UNION" <+> "ALL"+ <+> parenthesized (renderSQL q2)++-- | The results of two queries can be combined using the set operation+-- `intersect`, the intersection. Duplicate rows are eliminated.+intersect+ :: Query outer commons schemas params columns+ -> Query outer commons schemas params columns+ -> Query outer commons schemas params columns+q1 `intersect` q2 = UnsafeQuery $+ parenthesized (renderSQL q1)+ <+> "INTERSECT"+ <+> parenthesized (renderSQL q2)++-- | The results of two queries can be combined using the set operation+-- `intersectAll`, the intersection. Duplicate rows are retained.+intersectAll+ :: Query outer commons schemas params columns+ -> Query outer commons schemas params columns+ -> Query outer commons schemas params columns+q1 `intersectAll` q2 = UnsafeQuery $+ parenthesized (renderSQL q1)+ <+> "INTERSECT" <+> "ALL"+ <+> parenthesized (renderSQL q2)++-- | The results of two queries can be combined using the set operation+-- `except`, the set difference. Duplicate rows are eliminated.+except+ :: Query outer commons schemas params columns+ -> Query outer commons schemas params columns+ -> Query outer commons schemas params columns+q1 `except` q2 = UnsafeQuery $+ parenthesized (renderSQL q1)+ <+> "EXCEPT"+ <+> parenthesized (renderSQL q2)++-- | The results of two queries can be combined using the set operation+-- `exceptAll`, the set difference. Duplicate rows are retained.+exceptAll+ :: Query outer commons schemas params columns+ -> Query outer commons schemas params columns+ -> Query outer commons schemas params columns+q1 `exceptAll` q2 = UnsafeQuery $+ parenthesized (renderSQL q1)+ <+> "EXCEPT" <+> "ALL"+ <+> parenthesized (renderSQL q2)++{-----------------------------------------+SELECT queries+-----------------------------------------}++{- | The simplest kinds of `Selection` are `Star` and `DotStar` which+emits all columns that a `TableExpression` produces. A select `List`+is a list of `Expression`s. A `Selection` could be a list of+`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can+be selected with `Also`.+-}+data Selection outer commons grp schemas params from row where+ Star+ :: HasUnique tab from row+ => Selection outer commons 'Ungrouped schemas params from row+ -- ^ `HasUnique` table in the `FromClause`+ DotStar+ :: Has tab from row+ => Alias tab+ -- ^ `Has` table with `Alias`+ -> Selection outer commons 'Ungrouped schemas params from row+ List+ :: SListI row+ => NP (Aliased (Expression outer commons grp schemas params from)) row+ -- ^ `NP` list of `Aliased` `Expression`s+ -> Selection outer commons grp schemas params from row+ Over+ :: SListI row+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row+ -- ^ `NP` list of `Aliased` `WindowFunction`s+ -> WindowDefinition outer commons grp schemas params from+ -> Selection outer commons grp schemas params from row+ Also+ :: Selection outer commons grp schemas params from right+ -- ^ `Additional` `Selection`+ -> Selection outer commons grp schemas params from left+ -> Selection outer commons grp schemas params from (Join left right)+instance Additional (Selection outer commons grp schemas params from) where+ also = Also+instance (KnownSymbol col, row ~ '[col ::: ty])+ => Aliasable col+ (Expression outer commons grp schemas params from ty)+ (Selection outer commons grp schemas params from row) where+ expr `as` col = List (expr `as` col)+instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])+ => IsQualified tab col+ (Selection outer commons 'Ungrouped schemas params from row1) where+ tab ! col = tab ! col `as` col+instance+ ( Has tab (Join outer from) row0+ , Has col row0 ty+ , row1 ~ '[col ::: ty]+ , GroupedBy tab col bys )+ => IsQualified tab col+ (Selection outer commons ('Grouped bys) schemas params from row1) where+ tab ! col = tab ! col `as` col+instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])+ => IsLabel col+ (Selection outer commons 'Ungrouped schemas params from row1) where+ fromLabel = fromLabel @col `as` Alias+instance+ ( HasUnique tab (Join outer from) row0+ , Has col row0 ty+ , row1 ~ '[col ::: ty]+ , GroupedBy tab col bys )+ => IsLabel col+ (Selection outer commons ('Grouped bys) schemas params from row1) where+ fromLabel = fromLabel @col `as` Alias++instance RenderSQL (Selection outer commons grp schemas params from row) where+ renderSQL = \case+ List list -> renderCommaSeparated (renderAliased renderSQL) list+ Star -> "*"+ DotStar tab -> renderSQL tab <> ".*"+ Also right left -> renderSQL left <> ", " <> renderSQL right+ Over winFns winDef ->+ let+ renderOver+ :: Aliased (WindowFunction outer commons grp schemas params from) field+ -> ByteString+ renderOver (winFn `As` col) = renderSQL winFn+ <+> "OVER" <+> parenthesized (renderSQL winDef)+ <+> "AS" <+> renderSQL col+ in+ renderCommaSeparated renderOver winFns++instance IsString+ (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where+ fromString str = fromString str `as` Alias++-- | the `TableExpression` in the `select` command constructs an intermediate+-- virtual table by possibly combining tables, views, eliminating rows,+-- grouping, etc. This table is finally passed on to processing by+-- the select list. The `Selection` determines which columns of+-- the intermediate table are actually output.+select+ :: (SListI row, row ~ (x ': xs))+ => Selection outer commons grp schemas params from row+ -- ^ selection+ -> TableExpression outer commons grp schemas params from+ -- ^ intermediate virtual table+ -> Query outer commons schemas params row+select selection tabexpr = UnsafeQuery $+ "SELECT"+ <+> renderSQL selection+ <+> renderSQL tabexpr++-- | Like `select` but takes an `NP` list of `Expression`s instead+-- of a general `Selection`.+select_+ :: (SListI row, row ~ (x ': xs))+ => NP (Aliased (Expression outer commons grp schemas params from)) row+ -- ^ select list+ -> TableExpression outer commons grp schemas params from+ -- ^ intermediate virtual table+ -> Query outer commons schemas params row+select_ = select . List++-- | After the select list has been processed, the result table can+-- be subject to the elimination of duplicate rows using `selectDistinct`.+selectDistinct+ :: (SListI columns, columns ~ (col ': cols))+ => Selection outer commons 'Ungrouped schemas params from columns+ -- ^ selection+ -> TableExpression outer commons 'Ungrouped schemas params from+ -- ^ intermediate virtual table+ -> Query outer commons schemas params columns+selectDistinct selection tabexpr = UnsafeQuery $+ "SELECT DISTINCT"+ <+> renderSQL selection+ <+> renderSQL tabexpr++-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead+-- of a general `Selection`.+selectDistinct_+ :: (SListI columns, columns ~ (col ': cols))+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns+ -- ^ select list+ -> TableExpression outer commons 'Ungrouped schemas params from+ -- ^ intermediate virtual table+ -> Query outer commons schemas params columns+selectDistinct_ = selectDistinct . List++-- | `values` computes a row value or set of row values+-- specified by value expressions. It is most commonly used+-- to generate a “constant table” within a larger command,+-- but it can be used on its own.+--+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row+-- >>> printSQL query+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")+values+ :: SListI cols+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]+ -- ^ When more than one row is specified, all the rows must+ -- must have the same number of elements+ -> Query outer commons schemas params cols+values rw rws = UnsafeQuery $ "SELECT * FROM"+ <+> parenthesized (+ "VALUES"+ <+> commaSeparated+ ( parenthesized+ . renderCommaSeparated renderValuePart <$> rw:rws )+ ) <+> "AS t"+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)+ where+ renderAliasPart, renderValuePart+ :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString+ renderAliasPart (_ `As` name) = renderSQL name+ renderValuePart (value `As` _) = renderSQL value++-- | `values_` computes a row value or set of row values+-- specified by value expressions.+values_+ :: SListI cols+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols+ -- ^ one row of values+ -> Query outer commons schemas params cols+values_ rw = values rw []++{-----------------------------------------+Table Expressions+-----------------------------------------}++-- | 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+-- 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+ (outer :: FromType)+ (commons :: FromType)+ (grp :: Grouping)+ (schemas :: SchemasType)+ (params :: [NullityType])+ (from :: FromType)+ = TableExpression+ { fromClause :: FromClause outer commons schemas params from+ -- ^ A table reference that can be a table name, or a derived table such+ -- as a subquery, a @JOIN@ construct, or complex combinations of these.+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]+ -- ^ optional search coditions, combined with `.&&`. After the processing+ -- of the `fromClause` is done, each row of the derived virtual table+ -- is checked against the search condition. If the result of the+ -- condition is true, the row is kept in the output table,+ -- otherwise it is discarded. The search condition typically references+ -- at least one column of the table generated in the `fromClause`;+ -- this is not required, but otherwise the WHERE clause will+ -- be fairly useless.+ , groupByClause :: GroupByClause grp from+ -- ^ The `groupByClause` is used to group together those rows in a table+ -- that have the same values in all the columns listed. The order in which+ -- the columns are listed does not matter. The effect is to combine each+ -- set of rows having common values into one group row that represents all+ -- rows in the group. This is done to eliminate redundancy in the output+ -- and/or compute aggregates that apply to these groups.+ , havingClause :: HavingClause outer commons grp schemas params from+ -- ^ If a table has been grouped using `groupBy`, but only certain groups+ -- are of interest, the `havingClause` can be used, much like a+ -- `whereClause`, to eliminate groups from the result. Expressions in the+ -- `havingClause` can refer both to grouped expressions and to ungrouped+ -- expressions (which necessarily involve an aggregate function).+ , orderByClause :: [SortExpression outer commons grp schemas params from]+ -- ^ The `orderByClause` is for optional sorting. When more than one+ -- `SortExpression` is specified, the later (right) values are used to sort+ -- rows that are equal according to the earlier (left) values.+ , limitClause :: [Word64]+ -- ^ The `limitClause` is combined with `min` to give a limit count+ -- if nonempty. If a limit count is given, no more than that many rows+ -- will be returned (but possibly fewer, if the query itself yields+ -- fewer rows).+ , offsetClause :: [Word64]+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count+ -- 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.+ } deriving (GHC.Generic)++-- | Render a `TableExpression`+instance RenderSQL (TableExpression outer commons grp schemas params from) where+ renderSQL+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat+ [ "FROM ", renderSQL frm'+ , renderWheres whs'+ , renderSQL grps'+ , renderSQL hvs'+ , renderOrderByClause srts'+ , renderLimits lims'+ , renderOffsets offs' ]+ where+ renderWheres = \case+ [] -> ""+ wh:[] -> " WHERE" <+> renderSQL wh+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)+ renderOrderByClause = \case+ [] -> ""+ srts -> " ORDER BY"+ <+> commaSeparated (renderSQL <$> srts)+ renderLimits = \case+ [] -> ""+ lims -> " LIMIT" <+> fromString (show (minimum lims))+ renderOffsets = \case+ [] -> ""+ offs -> " OFFSET" <+> fromString (show (sum offs))++-- | 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,+-- or complex combinations of these. A `from` may be transformed by `where_`,+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator+-- to match the left-to-right sequencing of their placement in SQL.+from+ :: FromClause outer commons schemas params from -- ^ table reference+ -> TableExpression outer commons 'Ungrouped schemas params from+from tab = TableExpression tab [] NoGroups NoHaving [] [] []++-- | A `where_` is an endomorphism of `TableExpression`s which adds a+-- search condition to the `whereClause`.+where_+ :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition+ -> TableExpression outer commons grp schemas params from+ -> TableExpression outer commons grp schemas params from+where_ wh rels = rels {whereClause = wh : whereClause rels}++-- | A `groupBy` is a transformation of `TableExpression`s which switches+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform+-- a "grand total" aggregation query.+groupBy+ :: SListI bys+ => NP (By from) bys -- ^ grouped columns+ -> TableExpression outer commons 'Ungrouped schemas params from+ -> TableExpression outer commons ('Grouped bys) schemas params from+groupBy bys rels = TableExpression+ { fromClause = fromClause rels+ , whereClause = whereClause rels+ , groupByClause = Group bys+ , havingClause = Having []+ , orderByClause = []+ , limitClause = limitClause rels+ , offsetClause = offsetClause rels+ }++-- | A `having` is an endomorphism of `TableExpression`s which adds a+-- search condition to the `havingClause`.+having+ :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition+ -> TableExpression outer commons ('Grouped bys) schemas params from+ -> TableExpression outer commons ('Grouped bys) schemas params from+having hv rels = rels+ { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }++instance OrderBy TableExpression where+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}++-- | A `limit` is an endomorphism of `TableExpression`s which adds to the+-- `limitClause`.+limit+ :: Word64 -- ^ limit parameter+ -> TableExpression outer commons grp schemas params from+ -> TableExpression outer commons grp schemas params from+limit lim rels = rels {limitClause = lim : limitClause rels}++-- | An `offset` is an endomorphism of `TableExpression`s which adds to the+-- `offsetClause`.+offset+ :: Word64 -- ^ offset parameter+ -> TableExpression outer commons grp schemas params from+ -> TableExpression outer commons grp schemas params from+offset off rels = rels {offsetClause = off : offsetClause rels}++{-----------------------------------------+FROM clauses+-----------------------------------------}++{- |+A `FromClause` can be a table name, or a derived table such+as a subquery, a @JOIN@ construct, or complex combinations of these.+-}+newtype FromClause outer commons schemas params from+ = UnsafeFromClause { renderFromClause :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL (FromClause outer commons schemas params from) where+ renderSQL = renderFromClause++-- | A real `table` is a table from the database.+table+ :: (Has sch schemas schema, Has tab schema ('Table table))+ => Aliased (QualifiedAlias sch) (alias ::: tab)+ -> FromClause outer commons schemas params '[alias ::: TableToRow table]+table (tab `As` alias) = UnsafeFromClause $+ renderSQL tab <+> "AS" <+> renderSQL alias++-- | `subquery` derives a table from a `Query`.+subquery+ :: Aliased (Query outer commons schemas params) query+ -> FromClause outer commons schemas params '[query]+subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)++-- | `view` derives a table from a `View`.+view+ :: (Has sch schemas schema, Has vw schema ('View view))+ => Aliased (QualifiedAlias sch) (alias ::: vw)+ -> FromClause outer commons schemas params '[alias ::: view]+view (vw `As` alias) = UnsafeFromClause $+ renderSQL vw <+> "AS" <+> renderSQL alias++-- | `common` derives a table from a common table expression.+common+ :: Has cte commons common+ => Aliased Alias (alias ::: cte)+ -> FromClause outer commons schemas params '[alias ::: common]+common (cte `As` alias) = UnsafeFromClause $+ renderSQL cte <+> "AS" <+> renderSQL alias++instance Additional (FromClause outer commons schemas params) where+ also right left = UnsafeFromClause $+ renderSQL left <> ", " <> renderSQL right++{- |+@left & crossJoin right@. For every possible combination of rows from+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain+a row consisting of all columns in @left@ followed by all columns in @right@.+If the tables have @n@ and @m@ rows respectively, the joined table will+have @n * m@ rows.+-}+crossJoin+ :: FromClause outer commons schemas params right+ -- ^ right+ -> FromClause outer commons schemas params left+ -- ^ left+ -> FromClause outer commons schemas params (Join left right)+crossJoin right left = UnsafeFromClause $+ renderSQL left <+> "CROSS JOIN" <+> renderSQL right++{- | @left & innerJoin right on@. The joined table is filtered by+the @on@ condition.+-}+innerJoin+ :: FromClause outer commons schemas params right+ -- ^ right+ -> Condition outer commons 'Ungrouped schemas params (Join left right)+ -- ^ @on@ condition+ -> FromClause outer commons schemas params left+ -- ^ left+ -> FromClause outer commons schemas params (Join left right)+innerJoin right on left = UnsafeFromClause $+ renderSQL left <+> "INNER JOIN" <+> renderSQL right+ <+> "ON" <+> renderSQL on++{- | @left & leftOuterJoin right on@. First, an inner join is performed.+ Then, for each row in @left@ that does not satisfy the @on@ condition with+ any row in @right@, a joined row is added with null values in columns of @right@.+ Thus, the joined table always has at least one row for each row in @left@.+-}+leftOuterJoin+ :: FromClause outer commons schemas params right+ -- ^ right+ -> Condition outer commons 'Ungrouped schemas params (Join left right)+ -- ^ @on@ condition+ -> FromClause outer commons schemas params left+ -- ^ left+ -> FromClause outer commons schemas params (Join left (NullifyFrom right))+leftOuterJoin right on left = UnsafeFromClause $+ renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right+ <+> "ON" <+> renderSQL on++{- | @left & rightOuterJoin right on@. First, an inner join is performed.+ Then, for each row in @right@ that does not satisfy the @on@ condition with+ any row in @left@, a joined row is added with null values in columns of @left@.+ This is the converse of a left join: the result table will always+ have a row for each row in @right@.+-}+rightOuterJoin+ :: FromClause outer commons schemas params right+ -- ^ right+ -> Condition outer commons 'Ungrouped schemas params (Join left right)+ -- ^ @on@ condition+ -> FromClause outer commons schemas params left+ -- ^ left+ -> FromClause outer commons schemas params (Join (NullifyFrom left) right)+rightOuterJoin right on left = UnsafeFromClause $+ renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right+ <+> "ON" <+> renderSQL on++{- | @left & fullOuterJoin right on@. First, an inner join is performed.+ Then, for each row in @left@ that does not satisfy the @on@ condition with+ any row in @right@, a joined row is added with null values in columns of @right@.+ Also, for each row of @right@ that does not satisfy the join condition+ with any row in @left@, a joined row with null values in the columns of @left@+ is added.+-}+fullOuterJoin+ :: FromClause outer commons schemas params right+ -- ^ right+ -> Condition outer commons 'Ungrouped schemas params (Join left right)+ -- ^ @on@ condition+ -> FromClause outer commons schemas params left+ -- ^ left+ -> FromClause outer commons schemas params+ (Join (NullifyFrom left) (NullifyFrom right))+fullOuterJoin right on left = UnsafeFromClause $+ renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right+ <+> "ON" <+> renderSQL on++{-----------------------------------------+Grouping+-----------------------------------------}++-- | `By`s are used in `groupBy` to reference a list of columns which are then+-- used to group together those rows in a table that have the same values+-- in all the columns listed. @By \#col@ will reference an unambiguous+-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table+-- qualified column @tab.col@.+data By+ (from :: FromType)+ (by :: (Symbol,Symbol)) where+ By1+ :: (HasUnique table from columns, Has column columns ty)+ => Alias column+ -> By from '(table, column)+ By2+ :: (Has table from columns, Has column columns ty)+ => Alias table+ -> Alias column+ -> By from '(table, column)+deriving instance Show (By from by)+deriving instance Eq (By from by)+deriving instance Ord (By from by)+instance RenderSQL (By from by) where+ renderSQL = \case+ By1 column -> renderSQL column+ By2 rel column -> renderSQL rel <> "." <> renderSQL column++instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))+ => IsLabel col (By rels by) where fromLabel = By1 fromLabel+instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])+ => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil+instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))+ => IsQualified rel col (By rels by) where (!) = By2+instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])+ => IsQualified rel col (NP (By rels) bys) where+ rel ! col = By2 rel col :* Nil++-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.+-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.+-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be+-- done on @NoGroups@ while all output `Expression`s must be aggregated+-- in @Group Nil@. In general, all output `Expression`s in the+-- complement of @bys@ must be aggregated in @Group bys@.+data GroupByClause grp from where+ NoGroups :: GroupByClause 'Ungrouped from+ Group+ :: SListI bys+ => NP (By from) bys+ -> GroupByClause ('Grouped bys) from++-- | Renders a `GroupByClause`.+instance RenderSQL (GroupByClause grp from) where+ renderSQL = \case+ NoGroups -> ""+ Group Nil -> ""+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys++-- | A `HavingClause` is used to eliminate groups that are not of interest.+-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`+-- `TableExpression` must use `Having` whose conditions are combined with+-- `.&&`.+data HavingClause outer commons grp schemas params from where+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from+ Having+ :: [Condition outer commons ('Grouped bys) schemas params from]+ -> HavingClause outer commons ('Grouped bys) schemas params from+deriving instance Show (HavingClause outer commons grp schemas params from)+deriving instance Eq (HavingClause outer commons grp schemas params from)+deriving instance Ord (HavingClause outer commons grp schemas params from)++-- | Render a `HavingClause`.+instance RenderSQL (HavingClause outer commons grp schemas params from) where+ renderSQL = \case+ NoHaving -> ""+ Having [] -> ""+ Having conditions ->+ " HAVING" <+> commaSeparated (renderSQL <$> conditions)++-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.+data CommonTableExpression statement+ (schemas :: SchemasType)+ (params :: [NullityType])+ (commons0 :: FromType)+ (commons1 :: FromType) where+ CommonTableExpression+ :: Aliased (statement commons schemas params) (cte ::: common)+ -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)+instance+ ( KnownSymbol cte+ , commons1 ~ (cte ::: common ': commons)+ ) => Aliasable cte+ (statement commons schemas params common)+ (CommonTableExpression statement schemas params commons commons1) where+ statement `as` cte = CommonTableExpression (statement `as` cte)+instance+ ( KnownSymbol cte+ , commons1 ~ (cte ::: common ': commons)+ ) => Aliasable cte+ (statement commons schemas params common)+ (AlignedList (CommonTableExpression statement schemas params) commons commons1) where+ statement `as` cte = single (statement `as` cte)++instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL+ (CommonTableExpression statement schemas params commons0 commons1) where+ renderSQL (CommonTableExpression (statement `As` cte)) =+ renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)++-- | `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.+class With statement where+ with+ :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1+ -- ^ common table expressions+ -> statement commons1 schemas params row+ -- ^ larger query+ -> statement commons0 schemas params row+instance With (Query outer) where+ with Done query = query+ with ctes query = UnsafeQuery $+ "WITH" <+> renderSQL ctes <+> renderSQL query++{- |+>>> import Data.Monoid (Sum (..))+>>> import Data.Int (Int32)+>>> :{+ let+ query :: Query_ schema () (Sum Int32)+ query = withRecursive+ ( values_ (1 `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+:}+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (1)) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"+-}+withRecursive+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive+ -> Query outer (recursive ': commons) schemas params row+ -> Query outer commons schemas params row+withRecursive (recursive `As` cte) query = UnsafeQuery $+ "WITH RECURSIVE" <+> renderSQL cte+ <+> "AS" <+> parenthesized (renderSQL recursive)+ <+> renderSQL query
src/Squeal/PostgreSQL/Render.hs view
@@ -10,7 +10,9 @@ {-# LANGUAGE AllowAmbiguousTypes+ , ConstraintKinds , FlexibleContexts+ , LambdaCase , MagicHash , OverloadedStrings , PolyKinds@@ -21,30 +23,34 @@ module Squeal.PostgreSQL.Render ( -- * Render- parenthesized+ RenderSQL (..)+ , printSQL+ , escape+ , parenthesized+ , bracketed , (<+>) , commaSeparated , doubleQuoted , singleQuotedText , singleQuotedUtf8 , renderCommaSeparated+ , renderCommaSeparatedConstraint , renderCommaSeparatedMaybe , renderNat , renderSymbol- , RenderSQL (..)- , printSQL ) where -import Control.Monad.Base+import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString)-import Data.Maybe+import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text) import Generics.SOP import GHC.Exts-import GHC.TypeLits-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import GHC.TypeLits hiding (Text)++import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 @@ -52,6 +58,10 @@ parenthesized :: ByteString -> ByteString parenthesized str = "(" <> str <> ")" +-- | Square bracket a `ByteString`+bracketed :: ByteString -> ByteString+bracketed str = "[" <> str <> "]"+ -- | Concatenate two `ByteString`s with a space between. (<+>) :: ByteString -> ByteString -> ByteString infixr 7 <+>@@ -67,11 +77,12 @@ -- | Add single quotes around a `Text` and escape single quotes within it. singleQuotedText :: Text -> ByteString-singleQuotedText str = "'" <> T.encodeUtf8 (T.replace "'" "''" str) <> "'"+singleQuotedText str =+ "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'" -- | Add single quotes around a `ByteString` and escape single quotes within it. singleQuotedUtf8 :: ByteString -> ByteString-singleQuotedUtf8 = singleQuotedText . T.decodeUtf8+singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8 -- | Comma separate the renderings of a heterogeneous list. renderCommaSeparated@@ -83,6 +94,16 @@ . hcollapse . hmap (K . render) +-- | Comma separate the renderings of a heterogeneous list.+renderCommaSeparatedConstraint+ :: forall c xs expression. (All c xs, SListI xs)+ => (forall x. c x => expression x -> ByteString)+ -> NP expression xs -> ByteString+renderCommaSeparatedConstraint render+ = commaSeparated+ . hcollapse+ . hcmap (Proxy @c) (K . render)+ -- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping -- `Nothing`s. renderCommaSeparatedMaybe@@ -104,9 +125,21 @@ renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s)) -- | A class for rendering SQL-class RenderSQL sql where- renderSQL :: sql -> ByteString+class RenderSQL sql where renderSQL :: sql -> ByteString -- | Print SQL.-printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io ()-printSQL = liftBase . Char8.putStrLn . renderSQL+printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()+printSQL = liftIO . Char8.putStrLn . renderSQL++-- | `escape` a character to prevent injection+escape :: Char -> String+escape = \case+ '\NUL' -> "\\0"+ '\'' -> "''"+ '"' -> "\\\""+ '\b' -> "\\b"+ '\n' -> "\\n"+ '\r' -> "\\r"+ '\t' -> "\\t"+ '\\' -> "\\\\"+ c -> [c]
src/Squeal/PostgreSQL/Schema.hs view
@@ -1,16 +1,15 @@ {-| Module: Squeal.PostgreSQL.Schema Description: Embedding of PostgreSQL type and alias system-Copyright: (c) Eitan Chatav, 2017+Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -This module provides a type-level DSL for kinds of Postgres types,+`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types, tables, schema, constraints, aliases, enumerated labels, and groupings. It also defines useful type families to operate on these. Finally, it defines an embedding of Haskell types into Postgres types. -}-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds@@ -22,6 +21,7 @@ , GADTs , LambdaCase , OverloadedStrings+ , QuantifiedConstraints , RankNTypes , ScopedTypeVariables , StandaloneDeriving@@ -39,73 +39,37 @@ , NullityType (..) , RowType , FromType- -- * Haskell to Postgres Types- , PG- , NullPG- , TuplePG- , RowPG- , Json (..)- , Jsonb (..)- , Composite (..)- , Enumerated (..) -- * Schema Types , ColumnType , ColumnsType , TableType , SchemumType (..) , SchemaType+ , SchemasType+ , Public -- * Constraints , (:=>) , ColumnConstraint (..) , TableConstraint (..) , TableConstraints , Uniquely- -- * Aliases- , (:::)- , Alias (Alias)- , renderAlias- , renderAliases- , Aliased (As)- , Aliasable (as)- , renderAliasedAs- , Has- , HasUnique- , HasAll- , IsLabel (..)- , IsQualified (..)- , renderAliasString -- * Enumerated Labels , IsPGlabel (..) , PGlabel (..)- , renderLabel- , renderLabels- , LabelsPG- -- * Grouping- , Grouping (..)- , GroupedBy- -- * Aligned lists- , AlignedList (..)- , single -- * Data Definitions , Create , Drop , Alter , Rename+ , ConstraintInvolves , DropIfConstraintsInvolve- -- * Lists- , Join- , Elem- , In- , Length+ , IsNotElem+ , AllUnique -- * Type Classifications- , HasOid (..) , PGNum , PGIntegral , PGFloating , PGTypeOf- , PGArrayOf- , PGArray- , PGTextArray , PGJsonType , PGJsonKey , SamePGType@@ -117,41 +81,27 @@ , NullifyFrom -- * Table Conversions , TableToColumns+ , ColumnsToRow , TableToRow ) where import Control.Category-import Control.DeepSeq-import Data.Aeson (Value)-import Data.ByteString (ByteString)-import Data.Int (Int16, Int32, Int64) import Data.Kind import Data.Monoid hiding (All)-import Data.Scientific (Scientific)-import Data.String-import Data.Text (Text)-import Data.Time-import Data.Word (Word16, Word32, Word64) import Data.Type.Bool-import Data.UUID.Types (UUID)-import Data.Vector (Vector) import Generics.SOP-import Generics.SOP.Record-import GHC.OverloadedLabels import GHC.TypeLits-import Network.IP.Addr import Prelude hiding (id, (.)) -import qualified Data.ByteString.Lazy as Lazy-import qualified Data.Text.Lazy as Lazy-import qualified GHC.Generics as GHC-import qualified Generics.SOP.Type.Metadata as Type-+import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.List import Squeal.PostgreSQL.Render +-- $setup+-- >>> import Squeal.PostgreSQL+ -- | `PGType` is the promoted datakind of PostgreSQL types. ----- >>> import Squeal.PostgreSQL.Schema -- >>> :kind 'PGbool -- 'PGbool :: PGType data PGType@@ -162,6 +112,7 @@ | PGnumeric -- ^ arbitrary precision numeric type | PGfloat4 -- ^ single precision floating-point number (4 bytes) | PGfloat8 -- ^ double precision floating-point number (8 bytes)+ | PGmoney -- ^ currency amount | PGchar Nat -- ^ fixed-length character string | PGvarchar Nat -- ^ variable-length character string | PGtext -- ^ variable-length character string@@ -177,39 +128,13 @@ | PGjson -- ^ textual JSON data | PGjsonb -- ^ binary JSON data, decomposed | PGvararray NullityType -- ^ variable length array- | PGfixarray Nat NullityType -- ^ fixed length array+ | PGfixarray [Nat] NullityType -- ^ fixed length array | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values. | 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 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types --- | The object identifier of a `PGType`.------ >>> :set -XTypeApplications--- >>> oid @'PGbool--- 16-class HasOid (ty :: PGType) where oid :: Word32-instance HasOid 'PGbool where oid = 16-instance HasOid 'PGint2 where oid = 21-instance HasOid 'PGint4 where oid = 23-instance HasOid 'PGint8 where oid = 20-instance HasOid 'PGnumeric where oid = 1700-instance HasOid 'PGfloat4 where oid = 700-instance HasOid 'PGfloat8 where oid = 701-instance HasOid ('PGchar n) where oid = 18-instance HasOid ('PGvarchar n) where oid = 1043-instance HasOid 'PGtext where oid = 25-instance HasOid 'PGbytea where oid = 17-instance HasOid 'PGtimestamp where oid = 1114-instance HasOid 'PGtimestamptz where oid = 1184-instance HasOid 'PGdate where oid = 1082-instance HasOid 'PGtime where oid = 1083-instance HasOid 'PGtimetz where oid = 1266-instance HasOid 'PGinterval where oid = 1186-instance HasOid 'PGuuid where oid = 2950-instance HasOid 'PGinet where oid = 869-instance HasOid 'PGjson where oid = 114-instance HasOid 'PGjsonb where oid = 3802- -- | `NullityType` encodes the potential presence or definite absence of a -- @NULL@ allowing operations which are sensitive to such to be well typed. --@@ -228,11 +153,6 @@ type (:=>) constraint ty = '(constraint,ty) infixr 7 :=> --- | The alias operator `:::` is like a promoted version of `As`,--- a type level pair between an alias and some type.-type (:::) (alias :: Symbol) ty = '(alias,ty)-infixr 6 :::- -- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates. -- A column can be assigned a default value. -- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also@@ -274,7 +194,13 @@ | PrimaryKey [Symbol] | ForeignKey [Symbol] Symbol [Symbol] --- | A `TableConstraints` is a row of `TableConstraint`s.+{- | A `TableConstraints` is a row of `TableConstraint`s.++>>> :{+type family UsersConstraints :: TableConstraints where+ UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]+:}+-} type TableConstraints = [(Symbol,TableConstraint)] -- | A `ForeignKey` must reference columns that either are@@ -300,7 +226,7 @@ type TableType = (TableConstraints,ColumnsType) {- | A `RowType` is a row of `NullityType`. They correspond to Haskell-record types by means of `RowPG` and are used in many places.+record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places. >>> :{ type family PersonRow :: RowType where@@ -333,153 +259,6 @@ type family TableToRow (table :: TableType) :: RowType where TableToRow tab = ColumnsToRow (TableToColumns tab) --- | `Grouping` is an auxiliary namespace, created by--- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used--- for typesafe aggregation-data Grouping- = Ungrouped -- ^ no aggregation permitted- | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped--{- | A `GroupedBy` constraint indicates that a table qualified column is-a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,-may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.--}-class (KnownSymbol table, KnownSymbol column)- => GroupedBy table column bys where-instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)- => GroupedBy table column ('(table,column) ': bys)-instance {-# OVERLAPPABLE #-}- ( KnownSymbol table- , KnownSymbol column- , GroupedBy table column bys- ) => GroupedBy table column (tabcol ': bys)---- | `Alias`es are proxies for a type level string or `Symbol`--- and have an `IsLabel` instance so that with @-XOverloadedLabels@------ >>> :set -XOverloadedLabels--- >>> #foobar :: Alias "foobar"--- Alias-data Alias (alias :: Symbol) = Alias- deriving (Eq,GHC.Generic,Ord,Show,NFData)-instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where- fromLabel = Alias-instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where- fromLabel = fromLabel :* Nil-instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias---- | >>> renderAlias #jimbob--- "\"jimbob\""-renderAlias :: KnownSymbol alias => Alias alias -> ByteString-renderAlias = doubleQuoted . fromString . symbolVal---- | >>> renderAliasString #ohmahgerd--- "'ohmahgerd'"-renderAliasString :: KnownSymbol alias => Alias alias -> ByteString-renderAliasString = singleQuotedText . fromString . symbolVal---- | >>> import Generics.SOP (NP(..))--- >>> renderAliases (#jimbob :* #kandi)--- ["\"jimbob\"","\"kandi\""]-renderAliases- :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]-renderAliases = hcollapse- . hcmap (Proxy @KnownSymbol) (K . renderAlias)---- | The `As` operator is used to name an expression. `As` is like a demoted--- version of `:::`.------ >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)--- As (Just "hello") Alias-data Aliased expression aliased where- As- :: KnownSymbol alias- => expression ty- -> Alias alias- -> Aliased expression (alias ::: ty)-deriving instance Show (expression ty)- => Show (Aliased expression (alias ::: ty))-deriving instance Eq (expression ty)- => Eq (Aliased expression (alias ::: ty))-deriving instance Ord (expression ty)- => Ord (Aliased expression (alias ::: ty))-instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)- => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where- fromLabel = fromLabel @alias2 `As` fromLabel @alias1---- | The `Aliasable` class provides a way to scrap your `Nil`s--- in an `NP` list of `Aliased` expressions.-class KnownSymbol alias => Aliasable alias expression aliased- | aliased -> expression- , aliased -> alias- where as :: expression -> Alias alias -> aliased-instance (KnownSymbol alias, alias ~ alias1) => Aliasable alias- (expression ty)- (Aliased expression (alias1 ::: ty))- where- as = As-instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias- (expression ty)- (NP (Aliased expression) tys)- where- expression `as` alias = expression `As` alias :* Nil---- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")--- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)--- "Just AS \"an_int\""-renderAliasedAs- :: (forall ty. expression ty -> ByteString)- -> Aliased expression aliased- -> ByteString-renderAliasedAs render (expression `As` alias) =- render expression <> " AS " <> renderAlias alias---- | @HasUnique alias fields field@ is a constraint that proves that--- @fields@ is a singleton of @alias ::: field@.-type HasUnique alias fields field = fields ~ '[alias ::: field]---- | @Has alias fields field@ is a constraint that proves that--- @fields@ has a field of @alias ::: field@, inferring @field@--- from @alias@ and @fields@.-class KnownSymbol alias =>- Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)- | alias fields -> field where-instance {-# OVERLAPPING #-} KnownSymbol alias- => Has alias (alias ::: field ': fields) field-instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)- => Has alias (field' ': fields) field---- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer--- a list of @subfields@.-class- ( All KnownSymbol aliases- ) => HasAll- (aliases :: [Symbol])- (fields :: [(Symbol,kind)])- (subfields :: [(Symbol,kind)])- | aliases fields -> subfields where-instance {-# OVERLAPPING #-} HasAll '[] fields '[]-instance {-# OVERLAPPABLE #-}- (Has alias fields field, HasAll aliases fields subfields)- => HasAll (alias ': aliases) fields (alias ::: field ': subfields)---- | Analagous to `IsLabel`, the constraint--- `IsQualified` defines `!` for a column alias qualified--- by a table alias.-class IsQualified table column expression where- (!) :: Alias table -> Alias column -> expression- infixl 9 !-instance IsQualified table column (Alias table, Alias column) where (!) = (,)---- | @Elem@ is a promoted `Data.List.elem`.-type family Elem x xs where- Elem x '[] = 'False- Elem x (x ': xs) = 'True- Elem x (_ ': xs) = Elem x xs---- | @In x xs@ is a constraint that proves that @x@ is in @xs@.-type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True- -- | Numeric Postgres types. type PGNum = '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]@@ -490,37 +269,6 @@ -- | Integral Postgres types. type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8] --- | Error message helper for displaying unavailable\/unknown\/placeholder type--- variables whose kind is known.-type Placeholder k = 'Text "(_::" :<>: 'ShowType k :<>: 'Text ")"--type ErrArrayOf arr ty = arr :<>: 'Text " " :<>: ty-type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: Placeholder Nat) t-type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t---- | Ensure a type is a valid array type.-type family PGArray name arr :: Constraint where- PGArray name ('PGvararray x) = ()- PGArray name ('PGfixarray n x) = ()- PGArray name val = TypeError- ('Text name :<>: 'Text ": Unsatisfied PGArray constraint. Expected either: "- :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)- :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)- :$$: 'Text "But got: " :<>: 'ShowType val)---- | Ensure a type is a valid array type with a specific element type.-type family PGArrayOf name arr ty :: Constraint where- PGArrayOf name ('PGvararray x) ty = x ~ ty- PGArrayOf name ('PGfixarray n x) ty = x ~ ty- PGArrayOf name val ty = TypeError- ( 'Text name :<>: 'Text "Unsatisfied PGArrayOf constraint. Expected either: "- :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )- :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )- :$$: 'Text "But got: " :<>: 'ShowType val)---- | Ensure a type is a valid array type whose elements are text.-type PGTextArray name arr = PGArrayOf name arr ('NotNull 'PGtext)- -- | `PGTypeOf` forgets about @NULL@ and any column constraints. type family PGTypeOf (ty :: NullityType) :: PGType where PGTypeOf (nullity pg) = pg@@ -562,12 +310,6 @@ NullifyFrom (table ::: columns ': tables) = table ::: NullifyRow columns ': NullifyFrom tables --- | `Join` is simply promoted `++` and is used in @JOIN@s in--- `Squeal.PostgreSQL.Query.FromClause`s.-type family Join xs ys where- Join '[] ys = ys- Join (x ': xs) ys = x ': Join xs ys- -- | @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`.@@ -587,7 +329,7 @@ Drop alias (x ': xs) = x ': Drop alias xs -- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@--- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`+-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable` -- and `Squeal.PostgreSQL.Definition.alterColumn`. type family Alter alias x xs where Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs@@ -616,16 +358,6 @@ (DropIfConstraintsInvolve column constraints) (alias ::: constraint ': DropIfConstraintsInvolve column constraints) -{- | Calculate the `Length` of a type level list-->>> :kind! Length '[Char,String,Bool,Double]-Length '[Char,String,Bool,Double] :: Nat-= 4--}-type family Length (xs :: [k]) :: Nat where- Length (x : xs) = 1 + Length xs- Length '[] = 0- -- | A `SchemumType` is a user-defined type, either a `Table`, -- `View` or `Typedef`. data SchemumType@@ -657,6 +389,27 @@ -} type SchemaType = [(Symbol,SchemumType)] +{- |+A database contains one or more named schemas, which in turn contain tables.+The same object name can be used in different schemas without conflict;+for example, both schema1 and myschema can contain tables named mytable.+Unlike databases, schemas are not rigidly separated:+a user can access objects in any of the schemas in the database they are connected to,+if they have privileges to do so.++There are several reasons why one might want to use schemas:++ * To allow many users to use one database without interfering with each other.+ * To organize database objects into logical groups to make them more manageable.+ * Third-party applications can be put into separate schemas+ so they do not collide with the names of other objects.+-}+type SchemasType = [(Symbol,SchemaType)]++-- | A type family to use for a single schema database.+type family Public (schema :: SchemaType) :: SchemasType+ where Public schema = '["public" ::: schema]+ -- | `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@@ -668,195 +421,13 @@ => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil -- | A `PGlabel` unit type with an `IsPGlabel` instance data PGlabel (label :: Symbol) = PGlabel--- | Renders a label-renderLabel :: KnownSymbol label => proxy label -> ByteString-renderLabel (_ :: proxy label) =- "\'" <> renderSymbol @label <> "\'"--- | Renders a list of labels-renderLabels- :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]-renderLabels = hcollapse- . hcmap (Proxy @KnownSymbol) (K . renderLabel)--{- | The `PG` type family embeds a subset of Haskell types-as Postgres types. As an open type family, `PG` is extensible.-->>> :kind! PG LocalTime-PG LocalTime :: PGType-= 'PGtimestamp-->>> newtype MyDouble = My Double->>> type instance PG MyDouble = 'PGfloat8--}-type family PG (hask :: Type) :: PGType-type instance PG Bool = 'PGbool-type instance PG Int16 = 'PGint2-type instance PG Int32 = 'PGint4-type instance PG Int64 = 'PGint8-type instance PG Word16 = 'PGint2-type instance PG Word32 = 'PGint4-type instance PG Word64 = 'PGint8-type instance PG Scientific = 'PGnumeric-type instance PG Float = 'PGfloat4-type instance PG Double = 'PGfloat8-type instance PG Char = 'PGchar 1-type instance PG Text = 'PGtext-type instance PG Lazy.Text = 'PGtext-type instance PG String = 'PGtext-type instance PG ByteString = 'PGbytea-type instance PG Lazy.ByteString = 'PGbytea-type instance PG LocalTime = 'PGtimestamp-type instance PG UTCTime = 'PGtimestamptz-type instance PG Day = 'PGdate-type instance PG TimeOfDay = 'PGtime-type instance PG (TimeOfDay, TimeZone) = 'PGtimetz-type instance PG DiffTime = 'PGinterval-type instance PG UUID = 'PGuuid-type instance PG (NetAddr IP) = 'PGinet-type instance PG Value = 'PGjson-type instance PG (Json hask) = 'PGjson-type instance PG (Jsonb hask) = 'PGjsonb-type instance PG (Vector hask) = 'PGvararray (NullPG hask)-type instance PG (hask, hask) = 'PGfixarray 2 (NullPG hask)-type instance PG (hask, hask, hask) = 'PGfixarray 3 (NullPG hask)-type instance PG (hask, hask, hask, hask) = 'PGfixarray 4 (NullPG hask)-type instance PG (hask, hask, hask, hask, hask) = 'PGfixarray 5 (NullPG hask)-type instance PG (hask, hask, hask, hask, hask, hask)- = 'PGfixarray 6 (NullPG hask)-type instance PG (hask, hask, hask, hask, hask, hask, hask)- = 'PGfixarray 7 (NullPG hask)-type instance PG (hask, hask, hask, hask, hask, hask, hask, hask)- = 'PGfixarray 8 (NullPG hask)-type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask)- = 'PGfixarray 9 (NullPG hask)-type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask, hask)- = 'PGfixarray 10 (NullPG hask)-type instance PG (Composite hask) = 'PGcomposite (RowPG hask)-type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)--{- | The `Json` newtype is an indication that the Haskell-type it's applied to should be stored as `PGjson`.--}-newtype Json hask = Json {getJson :: hask}- deriving (Eq, Ord, Show, Read, GHC.Generic)--{- | The `Jsonb` newtype is an indication that the Haskell-type it's applied to should be stored as `PGjsonb`.--}-newtype Jsonb hask = Jsonb {getJsonb :: hask}- deriving (Eq, Ord, Show, Read, GHC.Generic)--{- | The `Composite` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGcomposite`.--}-newtype Composite record = Composite {getComposite :: record}- deriving (Eq, Ord, Show, Read, GHC.Generic)--{- | The `Enumerated` newtype is an indication that the Haskell-type it's applied to should be stored as `PGenum`.--}-newtype Enumerated enum = Enumerated {getEnumerated :: enum}- deriving (Eq, Ord, Show, Read, GHC.Generic)--{-| The `LabelsPG` type family calculates the constructors of a-Haskell enum type.-->>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic->>> instance Generic Schwarma->>> instance HasDatatypeInfo Schwarma->>> :kind! LabelsPG Schwarma-LabelsPG Schwarma :: [Type.ConstructorName]-= '["Beef", "Lamb", "Chicken"]--}-type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where- LabelsPG hask =- ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))--{- | `RowPG` turns a Haskell record type into a `RowType`.-->>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic->>> instance Generic Person->>> instance HasDatatypeInfo Person->>> :kind! RowPG Person-RowPG Person :: [(Symbol, NullityType)]-= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]--}-type family RowPG (hask :: Type) :: RowType where- RowPG hask = RowOf (RecordCodeOf hask)--type family RowOf (fields :: [(Symbol, Type)]) :: RowType where- RowOf '[] = '[]- RowOf (field ': fields) = FieldPG field ': RowOf fields--type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where- FieldPG (field ::: hask) = field ::: NullPG hask--{- | `NullPG` turns a Haskell type into a `NullityType`.-->>> :kind! NullPG Double-NullPG Double :: NullityType-= 'NotNull 'PGfloat8->>> :kind! NullPG (Maybe Double)-NullPG (Maybe Double) :: NullityType-= 'Null 'PGfloat8--}-type family NullPG (hask :: Type) :: NullityType where- NullPG (Maybe hask) = 'Null (PG hask)- NullPG hask = 'NotNull (PG hask)--{- | `TuplePG` turns a Haskell tuple type (including record types) into-the corresponding list of `NullityType`s.-->>> :kind! TuplePG (Double, Maybe Char)-TuplePG (Double, Maybe Char) :: [NullityType]-= '['NotNull 'PGfloat8, 'Null ('PGchar 1)]--}-type family TuplePG (hask :: Type) :: [NullityType] where- TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))--type family TupleOf (tuple :: [Type]) :: [NullityType] where- TupleOf '[] = '[]- TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple--type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where- TupleCodeOf hask '[tuple] = tuple- TupleCodeOf hask '[] =- TypeError- ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."- :$$: 'Text "It is a void type with no constructors."- )- TupleCodeOf hask (_ ': _ ': _) =- TypeError- ( 'Text "The type `" :<>: 'ShowType hask :<>: 'Text "' is not a tuple type."- :$$: 'Text "It is a sum type with more than one constructor."- )---- | Calculates constructors of a datatype.-type family ConstructorsOf (datatype :: Type.DatatypeInfo)- :: [Type.ConstructorInfo] where- ConstructorsOf ('Type.ADT _module _datatype constructors) =- constructors- ConstructorsOf ('Type.Newtype _module _datatype constructor) =- '[constructor]---- | Calculates the name of a nullary constructor, otherwise--- generates a type error.-type family ConstructorNameOf (constructors :: Type.ConstructorInfo)- :: Type.ConstructorName where- ConstructorNameOf ('Type.Constructor name) = name- ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError- ('Text "ConstructorNameOf error: non-nullary constructor "- ':<>: 'Text name)- ConstructorNameOf ('Type.Record name _fields) = TypeError- ('Text "ConstructorNameOf error: non-nullary constructor "- ':<>: 'Text name)---- | Calculate the names of nullary constructors.-type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])- :: [Type.ConstructorName] where- ConstructorNamesOf '[] = '[]- ConstructorNamesOf (constructor ': constructors) =- ConstructorNameOf constructor ': ConstructorNamesOf constructors+instance KnownSymbol label => RenderSQL (PGlabel label) where+ renderSQL _ = "\'" <> renderSymbol @label <> "\'"+instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where+ renderSQL+ = commaSeparated+ . hcollapse+ . hcmap (Proxy @KnownSymbol) (K . renderSQL) -- | Is a type a valid JSON key? type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]@@ -864,17 +435,15 @@ -- | Is a type a valid JSON type? type PGJsonType = '[ 'PGjson, 'PGjsonb ] --- | An `AlignedList` is a type-aligned list or free category.-data AlignedList p x0 x1 where- Done :: AlignedList p x x- (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2-infixr 7 :>>-instance Category (AlignedList p) where- id = Done- (.) list = \case- Done -> list- step :>> steps -> step :>> (steps >>> list)+-- | Utility class for `AllUnique` to provide nicer error messages.+class IsNotElem x isElem where+instance IsNotElem x 'False where+instance (TypeError ( 'Text "Cannot assign to "+ ':<>: 'ShowType alias+ ':<>: 'Text " more than once"))+ => IsNotElem '(alias, a) 'True where --- | A `single` step.-single :: p x0 x1 -> AlignedList p x0 x1-single step = step :>> Done+-- | No elem of @xs@ appears more than once, in the context of assignment.+class AllUnique (xs :: [(Symbol, a)]) where+instance AllUnique '[] where+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
src/Squeal/PostgreSQL/Transaction.hs view
@@ -1,7 +1,7 @@ {-| Module: Squeal.PostgreSQL.Transaction Description: Squeal transaction control language-Copyright: (c) Eitan Chatav, 2017+Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental @@ -20,89 +20,115 @@ ( -- * Transaction transactionally , transactionally_+ , transactionallyRetry+ , ephemerally+ , ephemerally_ , begin , commit , rollback- , transactionallySchema- , transactionallySchema_ -- * Transaction Mode , TransactionMode (..) , defaultMode , longRunningMode , IsolationLevel (..)- , renderIsolationLevel , AccessMode (..)- , renderAccessMode , DeferrableMode (..)- , renderDeferrableMode ) where -import Control.Exception.Lifted-import Control.Monad.Base-import Control.Monad.Trans.Control-import Data.ByteString-import Generics.SOP--import qualified Database.PostgreSQL.LibPQ as LibPQ+import UnliftIO import Squeal.PostgreSQL.Manipulation import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.PQ-import Squeal.PostgreSQL.Schema --- | Run a schema invariant computation `transactionally`.+{- | Run a computation `transactionally`;+first `begin`,+then run the computation,+`onException` `rollback` and rethrow the exception,+otherwise `commit` and `return` the result.+-} transactionally- :: (MonadBaseControl IO tx, MonadPQ schema tx)+ :: (MonadUnliftIO tx, MonadPQ schemas tx) => TransactionMode -> tx x -- ^ run inside a transaction -> tx x transactionally mode tx = mask $ \restore -> do- _ <- begin mode- result <- restore tx `onException` rollback- _ <- commit+ manipulate_ $ begin mode+ result <- restore tx `onException` (manipulate_ rollback)+ manipulate_ commit return result --- | Run a schema invariant computation `transactionally_` in `defaultMode`.+-- | Run a computation `transactionally_`, in `defaultMode`. transactionally_- :: (MonadBaseControl IO tx, MonadPQ schema tx)+ :: (MonadUnliftIO tx, MonadPQ schemas tx) => tx x -- ^ run inside a transaction -> tx x transactionally_ = transactionally defaultMode --- | @BEGIN@ a transaction.-begin :: MonadPQ schema tx => TransactionMode -> tx (K Result ('[] :: RowType))-begin mode = manipulate . UnsafeManipulation $- "BEGIN" <+> renderTransactionMode mode <> ";"---- | @COMMIT@ a schema invariant transaction.-commit :: MonadPQ schema tx => tx (K Result ('[] :: RowType))-commit = manipulate $ UnsafeManipulation "COMMIT;"+{- |+`transactionallyRetry` a computation; --- | @ROLLBACK@ a schema invariant transaction.-rollback :: MonadPQ schema tx => tx (K Result ('[] :: RowType))-rollback = manipulate $ UnsafeManipulation "ROLLBACK;"+* first `begin`,+* then `try` the computation,+ - if it raises a serialization failure then `rollback` and restart the transaction,+ - if it raises any other exception then `rollback` and rethrow the exception,+ - otherwise `commit` and `return` the result.+-}+transactionallyRetry+ :: (MonadUnliftIO tx, MonadPQ schemas tx)+ => TransactionMode+ -> tx x -- ^ run inside a transaction+ -> tx x+transactionallyRetry mode tx = mask $ \restore ->+ loop . try $ do+ x <- restore tx+ manipulate_ commit+ return x+ where+ loop attempt = do+ manipulate_ $ begin mode+ attempt >>= \case+ Left (PQException (PQState _ (Just "40001") _)) -> do+ manipulate_ rollback+ loop attempt+ Left err -> do+ manipulate_ rollback+ throwIO err+ Right x -> return x --- | Run a schema changing computation `transactionallySchema`.-transactionallySchema- :: MonadBaseControl IO io+{- | Run a computation `ephemerally`;+Like `transactionally` but always `rollback`, useful in testing.+-}+ephemerally+ :: (MonadUnliftIO tx, MonadPQ schemas tx) => TransactionMode- -> PQ schema0 schema1 io x- -> PQ schema0 schema1 io x-transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do- _ <- liftBase . LibPQ.exec (unK conn) $- "BEGIN" <+> renderTransactionMode mode <> ";"- x <- restore (unPQ u conn)- `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))- _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"- return x+ -> tx x -- ^ run inside an ephemeral transaction+ -> tx x+ephemerally mode tx = mask $ \restore -> do+ manipulate_ $ begin mode+ result <- restore tx `onException` (manipulate_ rollback)+ manipulate_ rollback+ return result --- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.-transactionallySchema_- :: MonadBaseControl IO io- => PQ schema0 schema1 io x- -> PQ schema0 schema1 io x-transactionallySchema_ = transactionallySchema defaultMode+{- | Run a computation `ephemerally` in `defaultMode`. -}+ephemerally_+ :: (MonadUnliftIO tx, MonadPQ schemas tx)+ => tx x -- ^ run inside an ephemeral transaction+ -> tx x+ephemerally_ = ephemerally defaultMode +-- | @BEGIN@ a transaction.+begin :: TransactionMode -> Manipulation_ schemas () ()+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode++-- | @COMMIT@ a transaction.+commit :: Manipulation_ schemas () ()+commit = UnsafeManipulation "COMMIT"++-- | @ROLLBACK@ a transaction.+rollback :: Manipulation_ schemas () ()+rollback = UnsafeManipulation "ROLLBACK"+ -- | The available transaction characteristics are the transaction `IsolationLevel`, -- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`. data TransactionMode = TransactionMode@@ -114,7 +140,7 @@ -- | `TransactionMode` with a `Serializable` `IsolationLevel`, -- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`. defaultMode :: TransactionMode-defaultMode = TransactionMode Serializable ReadWrite NotDeferrable+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable -- | `TransactionMode` with a `Serializable` `IsolationLevel`, -- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.@@ -123,12 +149,12 @@ longRunningMode = TransactionMode Serializable ReadOnly Deferrable -- | Render a `TransactionMode`.-renderTransactionMode :: TransactionMode -> ByteString-renderTransactionMode mode =- "ISOLATION LEVEL"- <+> renderIsolationLevel (isolationLevel mode)- <+> renderAccessMode (accessMode mode)- <+> renderDeferrableMode (deferrableMode mode)+instance RenderSQL TransactionMode where+ renderSQL mode =+ "ISOLATION LEVEL"+ <+> renderSQL (isolationLevel mode)+ <+> renderSQL (accessMode mode)+ <+> renderSQL (deferrableMode mode) -- | The SQL standard defines four levels of transaction isolation. -- The most strict is `Serializable`, which is defined by the standard in a paragraph@@ -179,12 +205,12 @@ deriving (Show, Eq) -- | Render an `IsolationLevel`.-renderIsolationLevel :: IsolationLevel -> ByteString-renderIsolationLevel = \case- Serializable -> "SERIALIZABLE"- ReadCommitted -> "READ COMMITTED"- ReadUncommitted -> "READ UNCOMMITTED"- RepeatableRead -> "REPEATABLE READ"+instance RenderSQL IsolationLevel where+ renderSQL = \case+ Serializable -> "SERIALIZABLE"+ ReadCommitted -> "READ COMMITTED"+ ReadUncommitted -> "READ UNCOMMITTED"+ RepeatableRead -> "REPEATABLE READ" -- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`. -- `ReadWrite` is the default. When a transaction is `ReadOnly`,@@ -201,10 +227,10 @@ deriving (Show, Eq) -- | Render an `AccessMode`.-renderAccessMode :: AccessMode -> ByteString-renderAccessMode = \case- ReadWrite -> "READ WRITE"- ReadOnly -> "READ ONLY"+instance RenderSQL AccessMode where+ renderSQL = \case+ ReadWrite -> "READ WRITE"+ ReadOnly -> "READ ONLY" -- | The `Deferrable` transaction property has no effect -- unless the transaction is also `Serializable` and `ReadOnly`.@@ -220,7 +246,7 @@ deriving (Show, Eq) -- | Render a `DeferrableMode`.-renderDeferrableMode :: DeferrableMode -> ByteString-renderDeferrableMode = \case- Deferrable -> "DEFERRABLE"- NotDeferrable -> "NOT DEFERRABLE"+instance RenderSQL DeferrableMode where+ renderSQL = \case+ Deferrable -> "DEFERRABLE"+ NotDeferrable -> "NOT DEFERRABLE"
test/Specs/ExceptionHandling.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} module ExceptionHandling ( specs@@ -15,7 +16,7 @@ where import Control.Monad (void)-import Control.Monad.Base (MonadBase)+import Control.Monad.IO.Class (MonadIO (..)) import qualified Data.ByteString.Char8 as Char8 import Data.Int (Int16) import Data.Text (Text)@@ -23,7 +24,6 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC import Squeal.PostgreSQL-import Squeal.PostgreSQL.Migration import Test.Hspec type Schema =@@ -45,21 +45,23 @@ ]) ] +type Schemas = Public Schema+ data User = User { userName :: Text , userEmail :: Maybe Text- , userVec :: Vector (Maybe Int16) }+ , userVec :: VarArray (Vector (Maybe Int16)) } deriving (Show, GHC.Generic) instance SOP.Generic User instance SOP.HasDatatypeInfo User -insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]+insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))] '[ "fromOnly" ::: 'NotNull 'PGint4 ]-insertUser = insertRows #users- (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec) []+insertUser = insertInto #users+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) OnConflictDoRaise (Returning (#id `as` #fromOnly)) -setup :: Definition '[] Schema+setup :: Definition (Public '[]) Schemas setup = createTable #users ( serial `as` #id :*@@ -76,32 +78,34 @@ foreignKey #user_id #users #id OnDeleteCascade OnUpdateCascade `as` #fk_user_id ) -teardown :: Definition Schema '[]+teardown :: Definition Schemas (Public '[]) teardown = dropTable #emails >>> dropTable #users -migration :: Migration IO '[] Schema+migration :: Migration Definition (Public '[]) Schemas migration = Migration { name = "test"- , up = void $ define setup- , down = void $ define teardown }+ , up = setup+ , down = teardown } setupDB :: IO ()-setupDB = void . withConnection connectionString $- migrateUp $ single migration+setupDB = withConnection connectionString $+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")+ & pqThen (migrateUp (single migration)) dropDB :: IO ()-dropDB = void . withConnection connectionString $- migrateDown $ single migration+dropDB = withConnection connectionString $+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")+ & pqThen (migrateDown (single migration)) connectionString :: Char8.ByteString connectionString = "host=localhost port=5432 dbname=exampledb" testUser :: User-testUser = User "TestUser" Nothing []+testUser = User "TestUser" Nothing (VarArray []) -newUser :: (MonadBase IO m, MonadPQ Schema m) => User -> m ()+newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m () newUser u = void $ manipulateParams insertUser (userName u, userVec u) -insertUserTwice :: (MonadBase IO m, MonadPQ Schema m) => m ()+insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m () insertUserTwice = newUser testUser >> newUser testUser specs :: SpecWith ()@@ -109,7 +113,7 @@ describe "Exceptions" $ do let- dupKeyErr = PQException FatalError (Just "23505")+ dupKeyErr = PQException $ PQState FatalError (Just "23505") (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n") it "should be thrown for unique constraint violation in a manipulation" $