squeal-postgresql (empty) → 0.1.0.0
raw patch · 19 files changed
+4960/−0 lines, 19 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, deepseq, doctest, generics-sop, hspec, lifted-base, monad-control, mtl, network-ip, postgresql-binary, postgresql-libpq, scientific, squeal-postgresql, text, time, transformers, transformers-base, uuid
Files
- LICENSE +31/−0
- README.md +7/−0
- Setup.hs +2/−0
- exe/Example.hs +109/−0
- squeal-postgresql.cabal +93/−0
- src/Squeal/PostgreSQL.hs +184/−0
- src/Squeal/PostgreSQL/Binary.hs +264/−0
- src/Squeal/PostgreSQL/Definition.hs +573/−0
- src/Squeal/PostgreSQL/Expression.hs +1140/−0
- src/Squeal/PostgreSQL/Manipulation.hs +368/−0
- src/Squeal/PostgreSQL/PQ.hs +575/−0
- src/Squeal/PostgreSQL/Prettyprint.hs +67/−0
- src/Squeal/PostgreSQL/Query.hs +775/−0
- src/Squeal/PostgreSQL/Schema.hs +324/−0
- test/DocTest.hs +14/−0
- test/Spec.hs +1/−0
- test/Squeal/PostgreSQL/DefinitionSpec.hs +124/−0
- test/Squeal/PostgreSQL/ManipulationSpec.hs +128/−0
- test/Squeal/PostgreSQL/QuerySpec.hs +181/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2017 Morphism, LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the names of the copyright holders nor the names of the+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,7 @@+# squeal++++[](https://circleci.com/gh/echatav/squeal)++Main repository for the squeal database library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Example.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE+ DataKinds+ , DeriveGeneric+ , OverloadedLabels+ , OverloadedStrings+ , TypeApplications+ , TypeOperators+#-}++module Main (main) where++import Control.Monad.Base (liftBase)+import Data.Int (Int32)+import Data.Monoid ((<>))+import Data.Text (Text)++import Squeal.PostgreSQL++import qualified Data.ByteString.Char8 as Char8+import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++type Schema =+ '[ "users" :::+ '[ "id" ::: 'Optional ('NotNull 'PGint4)+ , "name" ::: 'Required ('NotNull 'PGtext)+ ]+ , "emails" :::+ '[ "id" ::: 'Optional ('NotNull 'PGint4)+ , "user_id" ::: 'Required ('NotNull 'PGint4)+ , "email" ::: 'Required ('Null 'PGtext)+ ]+ ]++setup :: Definition '[] Schema+setup = + createTable #users+ ( serial `As` #id :*+ (text & notNull) `As` #name :* Nil )+ [ primaryKey (Column #id :* Nil) ]+ >>>+ createTable #emails+ ( serial `As` #id :*+ (int & notNull) `As` #user_id :*+ text `As` #email :* Nil )+ [ primaryKey (Column #id :* Nil)+ , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)+ OnDeleteCascade OnUpdateCascade ]++teardown :: Definition Schema '[]+teardown = dropTable #emails >>> dropTable #users++insertUser :: Manipulation Schema+ '[ 'Required ('NotNull 'PGtext)]+ '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]+insertUser = insertInto #users+ ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))++insertEmail :: Manipulation Schema+ '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]+insertEmail = insertInto #emails ( Values+ ( def `As` #id :*+ param @1 `As` #user_id :*+ param @2 `As` #email :* Nil) [] )+ OnConflictDoNothing (Returning Nil)++getUsers :: Query Schema '[]+ '[ "userName" ::: 'Required ('NotNull 'PGtext)+ , "userEmail" ::: 'Required ('Null 'PGtext) ]+getUsers = select+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)+ ( from (Table (#users `As` #u)+ & InnerJoin (Table (#emails `As` #e))+ (#u ! #id .== #e ! #user_id)) )++data User = User { userName :: Text, userEmail :: Maybe Text }+ deriving (Show, GHC.Generic)+instance SOP.Generic User+instance SOP.HasDatatypeInfo User++users :: [User]+users = + [ User "Alice" (Just "alice@gmail.com")+ , User "Bob" Nothing+ , User "Carole" (Just "carole@hotmail.com")+ ]++main :: IO ()+main = do+ Char8.putStrLn "squeal"+ connectionString <- pure+ "host=localhost port=5432 dbname=exampledb"+ Char8.putStrLn $ "connecting to " <> connectionString+ connection0 <- connectdb connectionString+ Char8.putStrLn "setting up schema"+ connection1 <- execPQ (define setup) connection0+ connection2 <- flip execPQ connection1 $ do+ liftBase $ Char8.putStrLn "manipulating"+ idResults <- traversePrepared insertUser (Only . userName <$> users)+ ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))+ liftBase $ Char8.putStrLn "querying"+ usersResult <- runQuery getUsers+ usersRows <- getRows usersResult+ liftBase $ print (usersRows :: [User])+ Char8.putStrLn "tearing down schema"+ connection3 <- execPQ (define teardown) connection2+ finish connection3
+ squeal-postgresql.cabal view
@@ -0,0 +1,93 @@+name: squeal-postgresql+version: 0.1.0.0+synopsis: Squeal PostgreSQL Library+description: Squeal is a type-safe embedding of PostgreSQL in Haskell+homepage: https://github.com/morphismtech/squeal+bug-reports: https://github.com/morphismtech/squeal/issues+license: BSD3+license-file: LICENSE+author: Eitan Chatav+maintainer: eitan.chatav@gmail.com+copyright: Copyright (c) 2017 Morphism, LLC+category: Database+build-type: Simple+cabal-version: >=1.18+extra-doc-files: README.md++source-repository head+ type: git+ location: https://github.com/morphismtech/squeal.git++library+ hs-source-dirs: src+ exposed-modules:+ Squeal.PostgreSQL+ Squeal.PostgreSQL.Binary+ Squeal.PostgreSQL.Definition+ Squeal.PostgreSQL.Expression+ Squeal.PostgreSQL.Manipulation+ Squeal.PostgreSQL.PQ+ Squeal.PostgreSQL.Prettyprint+ Squeal.PostgreSQL.Query+ Squeal.PostgreSQL.Schema+ default-language: Haskell2010+ ghc-options: -Wall -fprint-explicit-kinds+ build-depends:+ aeson >= 1.2.1.0 && < 2+ , base >= 4.10.0.0 && < 5+ , bytestring >= 0.10.8.2 && < 1+ , deepseq >= 1.4.3.0 && < 2+ , generics-sop >= 0.3.1.0 && < 1+ , lifted-base >= 0.2.3.11 && < 1+ , monad-control >= 1.0.2.2 && < 2+ , mtl >= 2.2.1 && < 3+ , network-ip >= 0.3.0.2 && < 1+ , postgresql-binary >= 0.12.1 && < 1+ , postgresql-libpq >= 0.9.3.1 && < 1+ , scientific >= 0.3.5.1 && < 1+ , text >= 1.2.2.2 && < 2+ , time >= 1.8.0.2 && < 2+ , transformers >= 0.5.2.0 && < 1+ , transformers-base >= 0.4.4 && < 1+ , uuid >= 1.3.13 && < 2++test-suite squeal-postgresql-spec+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ ghc-options: -Wall+ main-is: Spec.hs+ other-modules:+ Squeal.PostgreSQL.DefinitionSpec+ Squeal.PostgreSQL.ManipulationSpec+ Squeal.PostgreSQL.QuerySpec+ build-depends:+ base >= 4.10.0.0 && < 5+ , generics-sop >= 0.3.1.0 && < 1+ , hspec >= 2.4.4 && < 3+ , squeal-postgresql++test-suite squeal-postgresql-doctest+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ ghc-options: -Wall+ main-is: DocTest.hs+ build-depends:+ base >= 4.10.0.0 && < 5+ , doctest >= 0.11.4 && < 1++executable squeal-postgresql-example+ default-language: Haskell2010+ hs-source-dirs: exe+ ghc-options: -Wall+ main-is: Example.hs+ build-depends:+ base >= 4.10.0.0 && < 5+ , bytestring >= 0.10.8.2 && < 1+ , generics-sop >= 0.3.1.0 && < 1+ , mtl >= 2.2.1 && < 3+ , squeal-postgresql+ , text >= 1.2.2.2 && < 2+ , transformers >= 0.5.2.0 && < 1+ , transformers-base >= 0.4.4 && < 1
+ src/Squeal/PostgreSQL.hs view
@@ -0,0 +1,184 @@+-- | Module: Squeal.PostgreSQL+-- Description: Squeel export module+-- Copyright: (c) Eitan Chatav, 2017+-- Maintainer: eitan@morphism.tech+-- Stability: experimental+--+-- Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!+--+-- First, we need some language extensions because Squeal uses modern GHC+-- features.+--+-- > {-# LANGUAGE+-- > DataKinds+-- > , DeriveGeneric+-- > , OverloadedLabels+-- > , OverloadedStrings+-- > , TypeApplications+-- > , TypeOperators+-- > #-}+-- +-- Here comes the @Main@ module and imports.+--+-- > module Main (main) where+-- > +-- > import Control.Monad.Base (liftBase)+-- > import Data.Int (Int32)+-- > import Data.Text (Text)+-- >+-- > import Squeal.PostgreSQL+--+-- We'll use generics to easily convert between Haskell and PostgreSQL values.+--+-- > import qualified Generics.SOP as SOP+-- > import qualified GHC.Generics as GHC+--+-- The first step is to define the schema of our database. This is where+-- we use @DataKinds@ and @TypeOperators@. The schema consists of a type-level+-- list of tables, a `:::` pairing of a type level string or+-- `Data.TypeLit.Symbol` and a list a columns, itself a `:::` pairing of a+-- `Data.TypeLit.Symbol` and a `ColumnType`. The `ColumnType` describes the+-- PostgreSQL type of the column as well as whether or not it may contain+-- @NULL@ and whether or not inserts and updates can use a @DEFAULT@. For our+-- schema, we'll define two tables, a users table and an emails table.+--+-- > type Schema =+-- > '[ "users" :::+-- > '[ "id" ::: 'Optional ('NotNull 'PGint4)+-- > , "name" ::: 'Required ('NotNull 'PGtext)+-- > ]+-- > , "emails" :::+-- > '[ "id" ::: 'Optional ('NotNull 'PGint4)+-- > , "user_id" ::: 'Required ('NotNull 'PGint4)+-- > , "email" ::: 'Required ('Null 'PGtext)+-- > ]+-- > ]+--+-- Next, we'll write `Definition`s to set up and tear down the schema. In+-- Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`+-- command and 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+-- labels to refer to named tables and columns in our schema.+--+-- > setup :: Definition '[] Schema+-- > setup = +-- > createTable #users+-- > ( serial `As` #id :*+-- > (text & notNull) `As` #name :* Nil )+-- > [ primaryKey (Column #id :* Nil) ]+-- > >>>+-- > createTable #emails+-- > ( serial `As` #id :*+-- > (int & notNull) `As` #user_id :*+-- > text `As` #email :* Nil )+-- > [ primaryKey (Column #id :* Nil)+-- > , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)+-- > OnDeleteCascade OnUpdateCascade ]+--+-- Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.+-- In our `createTable` commands we included `TableConstraint`s to define+-- primary and foreign keys, making them somewhat complex. Our tear down+-- `Definition` is simpler.+--+-- > teardown :: Definition Schema '[]+-- > teardown = dropTable #emails >>> dropTable #users+--+-- Next, we'll write `Manipulation`s to insert data into our two tables.+-- A `Manipulation` is a `insertInto`, `update` or `deleteFrom` command and+-- 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 insert into the users table, we will need a parameter for the @name@+-- field but not for the @id@ field. Since it's optional, 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.+--+-- > insertUser :: Manipulation Schema+-- > '[ 'Required ('NotNull 'PGtext)]+-- > '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]+-- > insertUser = insertInto #users+-- > ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )+-- > OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))+-- > +-- > insertEmail :: Manipulation Schema+-- > '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]+-- > insertEmail = insertInto #emails ( Values+-- > ( def `As` #id :*+-- > param @1 `As` #user_id :*+-- > param @2 `As` #email :* Nil) [] )+-- > OnConflictDoNothing (Returning Nil)+--+-- 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.+--+-- > getUsers :: Query Schema '[]+-- > '[ "userName" ::: 'Required ('NotNull 'PGtext)+-- > , "userEmail" ::: 'Required ('Null 'PGtext) ]+-- > getUsers = select+-- > (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)+-- > ( from (Table (#users `As` #u)+-- > & InnerJoin (Table (#emails `As` #e))+-- > (#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.+--+-- > users :: [User]+-- > users = +-- > [ User "Alice" (Just "alice@gmail.com")+-- > , User "Bob" Nothing+-- > , User "Carole" (Just "carole@hotmail.com")+-- > ]+--+-- Now we can put together all the pieces into a program. The program+-- connects to the database, sets up the schema, inserts the user data+-- (using prepared statements as an optimization), queries the user+-- data and prints it out and finally closes the connection. Since the+-- `Connection` tracks the schema of the database, we get a new one+-- when we execute our statements.+-- +-- > main :: IO ()+-- > main = do+-- > connection0 <- connectdb "host=localhost port=5432 dbname=exampledb"+-- > connection1 <- execPQ (define setup) connection0+-- > connection2 <- flip execPQ connection1 $ do+-- > idResults <- traversePrepared insertUser (Only . userName <$> users)+-- > ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults+-- > traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))+-- > usersResult <- runQuery getUsers+-- > usersRows <- getRows usersResult+-- > liftBase $ print (usersRows :: [User])+-- > connection3 <- execPQ (define teardown) connection2+-- > finish connection3++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+ ) 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
+ src/Squeal/PostgreSQL/Binary.hs view
@@ -0,0 +1,264 @@+{-|+Module: Squeal.PostgreSQL.Binary+Description: Binary encoding and decoding+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Binary encoding and decoding between Haskell and PostgreSQL types.+-}++{-# LANGUAGE+ ConstraintKinds+ , DataKinds+ , DefaultSignatures+ , DeriveFoldable+ , DeriveFunctor+ , DeriveGeneric+ , DeriveTraversable+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , KindSignatures+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Binary+ ( -- * Encoding+ ToParam (..)+ , ToColumnParam (..)+ , ToParams (..)+ -- * Decoding+ , FromValue (..)+ , FromColumnValue (..)+ , FromRow (..)+ -- * Only+ , Only (..)+ ) where++import Data.Aeson hiding (Null)+import Data.Int+import Data.Kind+import Data.Scientific+import Data.Time+import Data.UUID+import Data.Word+import Generics.SOP+import GHC.TypeLits+import Network.IP.Addr++import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict hiding (unpack)+import qualified Data.Text.Lazy as Lazy+import qualified Data.Text as Strict+import qualified GHC.Generics as GHC+import qualified PostgreSQL.Binary.Decoding as Decoding+import qualified PostgreSQL.Binary.Encoding as Encoding++import Squeal.PostgreSQL.Schema++-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into+-- into the binary format of a PostgreSQL `PGType`.+class ToParam (x :: Type) (pg :: PGType) where+ -- | >>> :set -XTypeApplications -XDataKinds+ -- >>> toParam @Bool @'PGbool False+ -- K "\NUL"+ --+ -- >>> toParam @Int16 @'PGint2 0+ -- K "\NUL\NUL"+ --+ -- >>> toParam @Int32 @'PGint4 0+ -- K "\NUL\NUL\NUL\NUL"+ --+ -- >>> :set -XMultiParamTypeClasses+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show+ -- >>> instance ToParam Id 'PGint2 where toParam = toParam . getId+ -- >>> toParam @Id @'PGint2 (Id 1)+ -- K "\NUL\SOH"+ toParam :: x -> K Encoding.Encoding pg+instance ToParam Bool 'PGbool where toParam = K . Encoding.bool+instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16+instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32+instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64+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 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+instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict+instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy+instance ToParam Strict.ByteString 'PGbytea where+ toParam = K . Encoding.bytea_strict+instance ToParam Lazy.ByteString 'PGbytea where+ toParam = K . Encoding.bytea_lazy+instance ToParam Day 'PGdate where toParam = K . Encoding.date+instance ToParam TimeOfDay 'PGtime where toParam = K . Encoding.time_int+instance ToParam (TimeOfDay, TimeZone) 'PGtimetz where+ toParam = K . Encoding.timetz_int+instance ToParam LocalTime 'PGtimestamp where+ toParam = K . Encoding.timestamp_int+instance ToParam UTCTime 'PGtimestamptz where+ toParam = K . Encoding.timestamptz_int+instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int+instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast+instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast++-- | A `ToColumnParam` constraint lifts the `ToParam` encoding +-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should+-- not define instances of `ToColumnParam`, just use the provided instances.+class ToColumnParam (x :: Type) (ty :: ColumnType) where+ -- | >>> toColumnParam @Int16 @('Required ('NotNull 'PGint2)) 0+ -- K (Just "\NUL\NUL")+ --+ -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) (Just 0)+ -- K (Just "\NUL\NUL")+ --+ -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) Nothing+ -- K Nothing+ toColumnParam :: x -> K (Maybe Strict.ByteString) ty+instance ToParam x pg => ToColumnParam x (optionality ('NotNull pg)) where+ toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg+instance ToParam x pg => ToColumnParam (Maybe x) (optionality ('Null pg)) where+ toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)++-- | 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+-- which in turn provide `ToParams` instances.+class SListI tys => ToParams (x :: Type) (tys :: [ColumnType]) where+ -- | >>> type PGparams = '[ 'Required ('NotNull 'PGbool), 'Required ('Null 'PGint2)]+ -- >>> toParams @(Bool, Maybe Int16) @PGparams (False, Just 0)+ -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)+ --+ -- >>> :set -XDeriveGeneric+ -- >>> data Hparams = Hparams { col1 :: Bool, col2 :: Maybe Int16} deriving GHC.Generic+ -- >>> instance Generic Hparams+ -- >>> toParams @Hparams @PGparams (Hparams False (Just 0))+ -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)+ toParams :: x -> NP (K (Maybe Strict.ByteString)) tys+instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)+ => ToParams x tys where+ toParams+ = htrans (Proxy @ToColumnParam) (toColumnParam . unI)+ . unZ . unSOP . from++-- | A `FromValue` constraint gives a parser from the binary format of+-- a PostgreSQL `PGType` into a Haskell `Type`.+class FromValue (pg :: PGType) (y :: Type) where+ -- | >>> newtype Id = Id { getId :: Int16 } deriving Show+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue+ fromValue :: proxy pg -> Decoding.Value y+instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool+instance FromValue 'PGint2 Int16 where fromValue _ = Decoding.int+instance FromValue 'PGint4 Int32 where fromValue _ = Decoding.int+instance FromValue 'PGint8 Int64 where fromValue _ = Decoding.int+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 'PGuuid UUID where fromValue _ = Decoding.uuid+instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet+instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char+instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict+instance FromValue 'PGtext Lazy.Text where fromValue _ = Decoding.text_lazy+instance FromValue 'PGbytea Strict.ByteString where+ fromValue _ = Decoding.bytea_strict+instance FromValue 'PGbytea Lazy.ByteString where+ fromValue _ = Decoding.bytea_lazy+instance FromValue 'PGdate Day where fromValue _ = Decoding.date+instance FromValue 'PGtime TimeOfDay where fromValue _ = Decoding.time_int+instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where+ fromValue _ = Decoding.timetz_int+instance FromValue 'PGtimestamp LocalTime where+ fromValue _ = Decoding.timestamp_int+instance FromValue 'PGtimestamptz UTCTime where+ fromValue _ = Decoding.timestamptz_int+instance FromValue 'PGinterval DiffTime where+ fromValue _ = Decoding.interval_int+instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast+instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast++-- | A `FromColumnValue` constraint lifts the `FromValue` parser+-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,+-- decoding `Null`s to `Maybe`s. You should not define instances for+-- `FromColumnValue`, just use the provided instances.+class FromColumnValue (colty :: (Symbol,ColumnType)) (y :: Type) where+ -- | >>> :set -XTypeOperators -XOverloadedStrings+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue+ -- >>> fromColumnValue @("col" ::: 'Required ('NotNull 'PGint2)) @Id (K (Just "\NUL\SOH"))+ -- Id {getId = 1}+ --+ -- >>> fromColumnValue @("col" ::: 'Required ('Null 'PGint2)) @(Maybe Id) (K (Just "\NUL\SOH"))+ -- Just (Id {getId = 1})+ fromColumnValue :: K (Maybe Strict.ByteString) colty -> y+instance FromValue pg y+ => FromColumnValue (column ::: ('Required ('NotNull pg))) y where+ fromColumnValue = \case+ K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"+ K (Just bytes) ->+ let+ errOrValue =+ Decoding.valueParser (fromValue @pg @y Proxy) bytes+ err str = error $ "fromColumnValue: " ++ Strict.unpack str+ in+ either err id errOrValue+instance FromValue pg y+ => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where+ fromColumnValue (K nullOrBytes)+ = either err id+ . Decoding.valueParser (fromValue @pg @y Proxy)+ <$> nullOrBytes+ where+ err str = error $ "fromColumnValue: " ++ Strict.unpack str++-- | A `FromRow` constraint generically sequences the parsings of the columns+-- of a `ColumnsType` 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+-- provide `FromRow` instances.+class SListI results => FromRow (results :: ColumnsType) y where+ -- | >>> :set -XOverloadedStrings+ -- >>> import Data.Text+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue+ -- >>> data Hrow = Hrow { userId :: Id, userName :: Maybe Text } deriving (Show, GHC.Generic)+ -- >>> instance Generic Hrow+ -- >>> instance HasDatatypeInfo Hrow+ -- >>> type PGrow = '["userId" ::: 'Required ('NotNull 'PGint2), "userName" ::: 'Required ('Null 'PGtext)]+ -- >>> fromRow @PGrow @Hrow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)+ -- Hrow {userId = Id {getId = 1}, userName = Just "bloodninja"}+ fromRow :: NP (K (Maybe Strict.ByteString)) results -> y+instance+ ( SListI results+ , IsProductType y ys+ , AllZip FromColumnValue results ys+ , SameFields (DatatypeInfoOf y) results+ ) => FromRow results y where+ fromRow+ = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)++-- | `Only` is a 1-tuple type, useful for encoding a single parameter with+-- `toParams` or decoding a single value with `fromRow`.+--+-- >>> import Data.Text+-- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))+-- K (Just "foo") :* Nil+--+-- >>> type PGShortRow = '["fromOnly" ::: 'Required ('Null 'PGtext)]+-- >>> fromRow @PGShortRow @(Only (Maybe Text)) (K (Just "bar") :* Nil)+-- Only {fromOnly = Just "bar"}+newtype Only x = Only { fromOnly :: x }+ deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)+instance Generic (Only x)+instance HasDatatypeInfo (Only x)
+ src/Squeal/PostgreSQL/Definition.hs view
@@ -0,0 +1,573 @@+{-|+Module: Squeal.PostgreSQL.Definition+Description: Squeal data definition language+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal data definition language.+-}++{-# LANGUAGE+ DataKinds+ , DeriveDataTypeable+ , DeriveGeneric+ , GADTs+ , GeneralizedNewtypeDeriving+ , KindSignatures+ , LambdaCase+ , OverloadedStrings+ , RankNTypes+ , StandaloneDeriving+ , TypeInType+ , TypeOperators+#-}++module Squeal.PostgreSQL.Definition+ ( -- * Definition+ Definition (UnsafeDefinition, renderDefinition)+ , (>>>)+ -- * Create+ , createTable+ , TableConstraint (UnsafeTableConstraint, renderTableConstraint)+ , check+ , unique+ , primaryKey+ , foreignKey+ , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)+ , renderOnDeleteClause+ , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)+ , renderOnUpdateClause+ -- * Drop+ , dropTable+ -- * Alter+ , alterTable+ , alterTableRename+ , alterTableAddConstraint+ , AlterColumns (UnsafeAlterColumns, renderAlterColumns)+ , addColumnDefault+ , addColumnNull+ , dropColumn+ , dropColumnCascade+ , renameColumn+ , alterColumn+ , AlterColumn (UnsafeAlterColumn, renderAlterColumn)+ , setDefault+ , dropDefault+ , setNotNull+ , dropNotNull+ , alterType+ ) where++import Control.Category+import Control.DeepSeq+import Data.ByteString+import Data.Monoid+import GHC.TypeLits+import Prelude hiding ((.), id)++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Schema++{-----------------------------------------+statements+-----------------------------------------}++-- | A `Definition` is a statement that changes the schema of the+-- database, like a `createTable`, `dropTable`, or `alterTable` command.+-- `Definition`s may be composed using the `>>>` operator.+newtype Definition+ (schema0 :: TablesType)+ (schema1 :: TablesType)+ = UnsafeDefinition { renderDefinition :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++instance Category Definition where+ id = UnsafeDefinition ";"+ ddl1 . ddl0 = UnsafeDefinition $+ renderDefinition ddl0 <+> renderDefinition ddl1++{-----------------------------------------+CREATE statements+-----------------------------------------}++-- | `createTable` adds a table to the schema.+--+-- >>> :set -XOverloadedLabels+-- >>> :{+-- renderDefinition $+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) []+-- :}+-- "CREATE TABLE tab (a int, b real);"+createTable+ :: (KnownSymbol table, SOP.SListI columns)+ => Alias table -- ^ the name of the table to add+ -> NP (Aliased TypeExpression) (column ': columns)+ -- ^ the names and datatype of each column+ -> [TableConstraint schema (column ': columns)]+ -- ^ constraints that must hold for the table+ -> Definition schema (Create table (column ': columns) schema)+createTable table columns constraints = UnsafeDefinition $+ "CREATE TABLE" <+> renderAlias table+ <+> parenthesized+ ( renderCommaSeparated renderColumnDef columns+ <> renderConstraints constraints )+ <> ";"+ where+ renderColumnDef :: Aliased TypeExpression x -> ByteString+ renderColumnDef (ty `As` column) =+ renderAlias column <+> renderTypeExpression ty+ renderConstraints :: [TableConstraint schema columns] -> ByteString+ renderConstraints = \case+ [] -> ""+ _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)++-- | 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+-- too coarse. For example, a column containing a product price should+-- probably only accept positive values. But there is no standard data type+-- that accepts only positive numbers. Another issue is that you might want+-- to constrain column data with respect to other columns or rows.+-- For example, in a table containing product information,+-- there should be only one row for each product number.+-- `TableConstraint`s give you as much control over the data in your tables+-- as you wish. If a user attempts to store data in a column that would+-- violate a constraint, an error is raised. This applies+-- even if the value came from the default value definition.+newtype TableConstraint+ (schema :: TablesType)+ (columns :: ColumnsType)+ = UnsafeTableConstraint { renderTableConstraint :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | A `check` constraint is the most generic `TableConstraint` type.+-- It allows you to specify that the value in a certain column must satisfy+-- a Boolean (truth-value) expression.+--+-- >>> :{+-- renderDefinition $+-- createTable #tab+-- ( (int & notNull) `As` #a :*+-- (int & notNull) `As` #b :* Nil )+-- [ check (#a .> #b) ]+-- :}+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CHECK ((a > b)));"+check+ :: Condition '[table ::: columns] 'Ungrouped '[]+ -- ^ condition to check+ -> TableConstraint schema columns+check condition = UnsafeTableConstraint $+ "CHECK" <+> parenthesized (renderExpression 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.+--+-- >>> :{+-- renderDefinition $+-- createTable #tab+-- ( int `As` #a :*+-- int `As` #b :* Nil )+-- [ unique (Column #a :* Column #b :* Nil) ]+-- :}+-- "CREATE TABLE tab (a int, b int, UNIQUE (a, b));"+unique+ :: SOP.SListI subcolumns+ => NP (Column columns) subcolumns+ -- ^ unique column or group of columns+ -> TableConstraint schema columns+unique columns = UnsafeTableConstraint $+ "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)++-- | A `primaryKey` constraint indicates that a column, or group of columns,+-- can be used as a unique identifier for rows in the table.+-- This requires that the values be both unique and not null.+--+-- >>> :{+-- renderDefinition $+-- createTable #tab+-- ( serial `As` #id :*+-- (text & notNull) `As` #name :* Nil )+-- [ primaryKey (Column #id :* Nil) ]+-- :}+-- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"+primaryKey+ :: (SOP.SListI subcolumns, AllNotNull subcolumns)+ => NP (Column columns) subcolumns+ -- ^ identifying column or group of columns+ -> TableConstraint schema columns+primaryKey columns = UnsafeTableConstraint $+ "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)++-- | A `foreignKey` specifies that the values in a column+-- (or a group of columns) must match the values appearing in some row of+-- another table. We say this maintains the referential integrity+-- between two related tables.+--+-- >>> :{+-- let+-- definition :: Definition '[]+-- '[ "users" :::+-- '[ "id" ::: 'Optional ('NotNull 'PGint4)+-- , "username" ::: 'Required ('NotNull 'PGtext)+-- ]+-- , "emails" :::+-- '[ "id" ::: 'Optional ('NotNull 'PGint4)+-- , "userid" ::: 'Required ('NotNull 'PGint4)+-- , "email" ::: 'Required ('NotNull 'PGtext)+-- ]+-- ]+-- definition =+-- createTable #users+-- (serial `As` #id :* (text & notNull) `As` #username :* Nil)+-- [primaryKey (Column #id :* Nil)] >>>+-- createTable #emails+-- ( serial `As` #id :*+-- (integer & notNull) `As` #userid :*+-- (text & notNull) `As` #email :* Nil )+-- [ primaryKey (Column #id :* Nil)+-- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)+-- OnDeleteCascade OnUpdateRestrict+-- ]+-- in renderDefinition definition+-- :}+-- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"+foreignKey+ :: ( HasTable reftable schema refcolumns+ , SameTypes subcolumns refsubcolumns+ , AllNotNull subcolumns+ , SOP.SListI subcolumns+ , SOP.SListI refsubcolumns)+ => NP (Column columns) subcolumns+ -- ^ column or columns in the table+ -> Alias reftable+ -- ^ reference table+ -> NP (Column refcolumns) refsubcolumns+ -- ^ reference column or columns in the reference table+ -> OnDeleteClause+ -- ^ what to do when reference is deleted+ -> OnUpdateClause+ -- ^ what to do when reference is updated+ -> TableConstraint schema columns+foreignKey columns reftable refcolumns onDelete onUpdate =+ UnsafeTableConstraint $+ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)+ <+> "REFERENCES" <+> renderAlias reftable+ <+> parenthesized (renderCommaSeparated renderColumn refcolumns)+ <+> renderOnDeleteClause onDelete+ <+> renderOnUpdateClause onUpdate++-- | `OnDelete` indicates what to do with rows that reference a deleted row.+data OnDeleteClause+ = OnDeleteNoAction+ -- ^ if any referencing rows still exist when the constraint is checked,+ -- an error is raised+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row+ | OnDeleteCascade+ -- ^ specifies that when a referenced row is deleted,+ -- row(s) referencing it should be automatically deleted as well+ 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"++-- | Analagous to `OnDelete` there is also `OnUpdate` which is invoked+-- when a referenced column is changed (updated).+data OnUpdateClause+ = OnUpdateNoAction+ -- ^ if any referencing rows has not changed when the constraint is checked,+ -- an error is raised+ | OnUpdateRestrict -- ^ prevents update of a referenced row+ | OnUpdateCascade+ -- ^ the updated values of the referenced column(s) should be copied+ -- into the referencing row(s)+ deriving (GHC.Generic,Show,Eq,Ord)+instance NFData OnUpdateClause++-- | Render `OnUpdateClause`.+renderOnUpdateClause :: OnUpdateClause -> ByteString+renderOnUpdateClause = \case+ OnUpdateNoAction -> "ON UPDATE NO ACTION"+ OnUpdateRestrict -> "ON UPDATE RESTRICT"+ OnUpdateCascade -> "ON UPDATE CASCADE"++{-----------------------------------------+DROP statements+-----------------------------------------}++-- | `dropTable` removes a table from the schema.+--+-- >>> renderDefinition $ dropTable #muh_table+-- "DROP TABLE muh_table;"+dropTable+ :: KnownSymbol table+ => Alias table -- ^ table to remove+ -> Definition schema (Drop table schema)+dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"++{-----------------------------------------+ALTER statements+-----------------------------------------}++-- | `alterTable` changes the definition of a table from the schema.+alterTable+ :: HasTable table schema columns0+ => Alias table -- ^ table to alter+ -> AlterColumns columns0 columns1 -- ^ alteration to perform+ -> Definition schema (Alter table schema columns1)+alterTable table alteration = UnsafeDefinition $+ "ALTER TABLE"+ <+> renderAlias table+ <+> renderAlterColumns alteration+ <> ";"++-- | `alterTableRename` changes the name of a table from the schema.+--+-- >>> renderDefinition $ alterTableRename #foo #bar+-- "ALTER TABLE foo RENAME TO bar;"+alterTableRename+ :: (KnownSymbol table0, KnownSymbol table1)+ => Alias table0 -- ^ table to rename+ -> Alias table1 -- ^ what to rename it+ -> Definition schema (Rename table0 table1 schema)+alterTableRename table0 table1 = UnsafeDefinition $+ "ALTER TABLE" <+> renderAlias table0+ <+> "RENAME TO" <+> renderAlias table1 <> ";"++-- | An `alterTableAddConstraint` adds a table constraint.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]+-- definition = alterTableAddConstraint #tab (check (#col .> 0))+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ADD CHECK ((col > 0));"+alterTableAddConstraint+ :: HasTable table schema columns+ => Alias table -- ^ table to constrain+ -> TableConstraint schema columns -- ^ what constraint to add+ -> Definition schema schema+alterTableAddConstraint table constraint = UnsafeDefinition $+ "ALTER TABLE" <+> renderAlias table+ <+> "ADD" <+> renderTableConstraint constraint <> ";"++-- | An `AlterColumns` describes the alteration to perform on the columns+-- of a table.+newtype AlterColumns+ (columns0 :: ColumnsType)+ (columns1 :: ColumnsType) =+ UnsafeAlterColumns {renderAlterColumns :: ByteString}+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | An `addColumnDefault` adds a new `Optional` column. The new column is+-- initially filled with whatever default value is given.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]+-- '["tab" :::+-- '[ "col1" ::: 'Required ('Null 'PGint4)+-- , "col2" ::: 'Optional ('Null 'PGtext) ]]+-- definition = alterTable #tab+-- (addColumnDefault #col2 (text & default_ "foo"))+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"+addColumnDefault+ :: KnownSymbol column+ => Alias column -- ^ column to add+ -> TypeExpression ('Optional ty) -- ^ type of the new column+ -> AlterColumns columns (Create column ('Optional ty) columns)+addColumnDefault column ty = UnsafeAlterColumns $+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty++-- | An `addColumnDefault` adds a new `Null` column. The new column is+-- initially filled with %NULL%s.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]+-- '["tab" :::+-- '[ "col1" ::: 'Required ('Null 'PGint4)+-- , "col2" ::: 'Required ('Null 'PGtext) ]]+-- definition = alterTable #tab (addColumnNull #col2 text)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ADD COLUMN col2 text;"+addColumnNull+ :: KnownSymbol column+ => Alias column -- ^ column to add+ -> TypeExpression ('Required ('Null ty)) -- ^ type of the new column+ -> AlterColumns columns (Create column ('Required ('Null ty)) columns)+addColumnNull column ty = UnsafeAlterColumns $+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty++-- | A `dropColumn` removes a column. Whatever data was in the column+-- disappears. Table constraints involving the column are dropped, too.+-- However, if the column is referenced by a foreign key constraint of+-- another table, PostgreSQL will not silently drop that constraint.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" :::+-- '[ "col1" ::: 'Required ('Null 'PGint4)+-- , "col2" ::: 'Required ('Null 'PGtext) ]]+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]+-- definition = alterTable #tab (dropColumn #col2)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab DROP COLUMN col2;"+dropColumn+ :: KnownSymbol column+ => Alias column -- ^ column to remove+ -> AlterColumns columns (Drop column columns)+dropColumn column = UnsafeAlterColumns $+ "DROP COLUMN" <+> renderAlias column++-- | Like `dropColumn` but authorizes dropping everything that depends+-- on the column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" :::+-- '[ "col1" ::: 'Required ('Null 'PGint4)+-- , "col2" ::: 'Required ('Null 'PGtext) ]]+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]+-- definition = alterTable #tab (dropColumnCascade #col2)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab DROP COLUMN col2 CASCADE;"+dropColumnCascade+ :: KnownSymbol column+ => Alias column -- ^ column to remove+ -> AlterColumns columns (Drop column columns)+dropColumnCascade column = UnsafeAlterColumns $+ "DROP COLUMN" <+> renderAlias column <+> "CASCADE"++-- | A `renameColumn` renames a column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["foo" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '["bar" ::: 'Required ('Null 'PGint4)]]+-- definition = alterTable #tab (renameColumn #foo #bar)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab RENAME COLUMN foo TO bar;"+renameColumn+ :: (KnownSymbol column0, KnownSymbol column1)+ => Alias column0+ -> Alias column1+ -> AlterColumns columns (Rename column0 column1 columns)+renameColumn column0 column1 = UnsafeAlterColumns $+ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1++-- | An `alterColumn` alters a single column.+alterColumn+ :: (KnownSymbol column, HasColumn column columns ty0)+ => Alias column -- ^ column to alter+ -> AlterColumn ty0 ty1 -- ^ alteration to perform+ -> AlterColumns columns (Alter column columns ty1)+alterColumn column alteration = UnsafeAlterColumns $+ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration++-- | An `AlterColumn` describes the alteration to perform on a single column.+newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =+ UnsafeAlterColumn {renderAlterColumn :: ByteString}+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | A `setDefault` sets a new default for a column. Note that this doesn't+-- affect any existing rows in the table, it just changes the default for+-- future `insertTable` and `updateTable` commands.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]+-- definition = alterTable #tab (alterColumn #col (setDefault 5))+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ALTER COLUMN col SET DEFAULT 5;"+setDefault+ :: Expression '[] 'Ungrouped '[] ('Required ty) -- ^ default value to set+ -> AlterColumn (optionality ty) ('Optional ty)+setDefault expression = UnsafeAlterColumn $+ "SET DEFAULT" <+> renderExpression expression++-- | A `dropDefault` removes any default value for a column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]+-- definition = alterTable #tab (alterColumn #col dropDefault)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ALTER COLUMN col DROP DEFAULT;"+dropDefault :: AlterColumn (optionality ty) ('Required ty)+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"++-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.+-- The constraint will be checked immediately, so the table data must satisfy+-- the constraint before it can be added.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]+-- definition = alterTable #tab (alterColumn #col setNotNull)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ALTER COLUMN col SET NOT NULL;"+setNotNull :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"++-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]+-- definition = alterTable #tab (alterColumn #col dropNotNull)+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ALTER COLUMN col DROP NOT NULL;"+dropNotNull :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"++-- | An `alterType` converts a column to a different data type.+-- This will succeed only if each existing entry in the column can be+-- converted to the new type by an implicit cast.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGnumeric)]]+-- definition =+-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))+-- in renderDefinition definition+-- :}+-- "ALTER TABLE tab ALTER COLUMN col TYPE numeric NOT NULL;"+alterType :: TypeExpression ty -> AlterColumn ty0 ty1+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty
+ src/Squeal/PostgreSQL/Expression.hs view
@@ -0,0 +1,1140 @@+{-|+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+ , DataKinds+ , DeriveGeneric+ , DeriveDataTypeable+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MagicHash+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression + ( -- * Expression+ Expression (UnsafeExpression, renderExpression)+ , HasParameter (param)+ , HasColumn (getColumn)+ , Column (Column)+ , renderColumn+ , GroupedBy (getGroup1, getGroup2)+ -- ** Default+ , def+ , unDef+ -- ** Null+ , null_+ , unNull+ , coalesce+ , fromNull+ , isNull+ , isn'tNull+ , matchNull+ , nullIf+ -- ** Functions+ , unsafeBinaryOp+ , unsafeUnaryOp+ , unsafeFunction+ , atan2_+ , cast+ , quot_+ , rem_+ , trunc+ , round_+ , ceiling_+ , greatest+ , least+ -- ** Conditions+ , Condition+ , true+ , false+ , not_+ , (.&&)+ , (.||)+ , caseWhenThenElse+ , ifThenElse+ , (.==)+ , (./=)+ , (.>=)+ , (.<)+ , (.<=)+ , (.>)+ -- ** Time+ , currentDate+ , currentTime+ , currentTimestamp+ , localTime+ , localTimestamp+ -- ** Text+ , lower+ , upper+ , charLength+ , like+ -- ** 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+ -- * Tables+ , Table (UnsafeTable, renderTable)+ , HasTable (getTable)+ -- * TypeExpression+ , TypeExpression (UnsafeTypeExpression, renderTypeExpression)+ , PGTyped (pgtype)+ , bool+ , int2+ , smallint+ , int4+ , int+ , integer+ , int8+ , bigint+ , numeric+ , float4+ , real+ , float8+ , doublePrecision+ , serial2+ , smallserial+ , serial4+ , serial+ , serial8+ , bigserial+ , text+ , char+ , character+ , varchar+ , characterVarying+ , bytea+ , timestamp+ , timestampWithTimeZone+ , date+ , time+ , timeWithTimeZone+ , interval+ , uuid+ , inet+ , json+ , jsonb+ , notNull+ , default_+ -- * Re-export+ , (&)+ , NP ((:*), Nil)+ ) where++import Control.Category+import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.Function ((&))+import Data.Monoid hiding (All)+import Data.Ratio+import Data.String+import Generics.SOP hiding (from)+import GHC.OverloadedLabels+import GHC.TypeLits+import Prelude hiding (id, (.))++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Schema++{-----------------------------------------+column expressions+-----------------------------------------}++{- | `Expression`s are used in a variety of contexts,+such as in the target list of the `select` command,+as new column values in `insertInto` or `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+ (tables :: TablesType)+ (grouping :: Grouping)+ (params :: [ColumnType])+ (ty :: ColumnType)+ = UnsafeExpression { renderExpression :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++{- | 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 (PGTyped (BaseType ty), KnownNat n)+ => HasParameter (n :: Nat) params ty | n params -> ty where+ param :: Expression tables grouping params ty+ param = UnsafeExpression $ parenthesized $+ "$" <> renderNat (Proxy @n) <+> "::"+ <+> renderTypeExpression (pgtype @(BaseType ty))+instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)+ => HasParameter 1 (ty1:tys) ty1+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)+ => HasParameter n (ty' : params) ty++{- | A `HasColumn` constraint indicates an unqualified column reference.+`getColumn` can only be unambiguous when the `TableExpression` the column+references is unique, in which case the column may be referenced using+@-XOverloadedLabels@. Otherwise, combined with a `HasTable` constraint, the+qualified column reference operator `!` may be used.+-}+class KnownSymbol column => HasColumn column columns ty+ | column columns -> ty where+ getColumn+ :: HasUnique table tables columns+ => Alias column+ -> Expression tables 'Ungrouped params ty+ getColumn column = UnsafeExpression $ renderAlias column+instance {-# OVERLAPPING #-} KnownSymbol column+ => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)+instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)+ => HasColumn column (ty' ': table) ty++instance (HasColumn column columns ty, HasUnique table tables columns)+ => IsLabel column (Expression tables 'Ungrouped params ty) where+ fromLabel = getColumn (Alias @column)++instance (HasTable table tables columns, HasColumn column columns ty)+ => IsTableColumn table column (Expression tables 'Ungrouped params ty) where+ table ! column = UnsafeExpression $+ renderAlias table <> "." <> renderAlias column++-- | A `Column` is a witness to a `HasColumn` constraint. It's used+-- in `Squeel.PostgreSQL.Definition.unique` and other+-- `Squeel.PostgreSQL.Definition.TableConstraint`s to witness a+-- subcolumns relationship.+data Column+ (columns :: ColumnsType)+ (columnty :: (Symbol,ColumnType))+ where+ Column+ :: HasColumn column columns ty+ => Alias column+ -> Column columns (column ::: ty)+deriving instance Show (Column columns columnty)+deriving instance Eq (Column columns columnty)+deriving instance Ord (Column columns columnty)++-- | Render a `Column`.+renderColumn :: Column columns columnty -> ByteString+renderColumn (Column column) = renderAlias column++{- | 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 `Expression` without aggregating.+-}+class (KnownSymbol table, KnownSymbol column)+ => GroupedBy table column bys where+ getGroup1+ :: (HasUnique table tables columns, HasColumn column columns ty)+ => Alias column+ -> Expression tables ('Grouped bys) params ty+ getGroup1 column = UnsafeExpression $ renderAlias column+ getGroup2+ :: (HasTable table tables columns, HasColumn column columns ty)+ => Alias table+ -> Alias column+ -> Expression tables ('Grouped bys) params ty+ getGroup2 table column = UnsafeExpression $+ renderAlias table <> "." <> renderAlias column+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)+ +instance+ ( HasUnique table tables columns+ , HasColumn column columns ty+ , GroupedBy table column bys+ ) => IsLabel column+ (Expression tables ('Grouped bys) params ty) where+ fromLabel = getGroup1 (Alias @column)+ +instance+ ( HasTable table tables columns+ , HasColumn column columns ty+ , GroupedBy table column bys+ ) => IsTableColumn table column+ (Expression tables ('Grouped bys) params ty) where (!) = getGroup2++-- | >>> renderExpression def+-- "DEFAULT"+def :: Expression '[] 'Ungrouped params ('Optional (nullity ty))+def = UnsafeExpression "DEFAULT"++-- | >>> renderExpression $ unDef false+-- "FALSE"+unDef+ :: Expression '[] 'Ungrouped params ('Required (nullity ty))+ -- ^ not @DEFAULT@+ -> Expression '[] 'Ungrouped params ('Optional (nullity ty))+unDef = UnsafeExpression . renderExpression++-- | analagous to `Nothing`+--+-- >>> renderExpression $ null_+-- "NULL"+null_ :: Expression tables grouping params (optionality ('Null ty))+null_ = UnsafeExpression "NULL"++-- | analagous to `Just`+--+-- >>> renderExpression $ unNull true+-- "TRUE"+unNull+ :: Expression tables grouping params (optionality ('NotNull ty))+ -- ^ not @NULL@+ -> Expression tables grouping params (optionality ('Null ty))+unNull = UnsafeExpression . renderExpression++-- | return the leftmost value which is not NULL+--+-- >>> renderExpression $ coalesce [null_, unNull true] false+-- "COALESCE(NULL, TRUE, FALSE)"+coalesce+ :: [Expression tables grouping params ('Required ('Null ty))]+ -- ^ @NULL@s may be present+ -> Expression tables grouping params ('Required ('NotNull ty))+ -- ^ @NULL@ is absent+ -> Expression tables grouping params ('Required ('NotNull ty))+coalesce nullxs notNullx = UnsafeExpression $+ "COALESCE" <> parenthesized (commaSeparated+ ((renderExpression <$> nullxs) <> [renderExpression notNullx]))++-- | analagous to `fromMaybe` using @COALESCE@+--+-- >>> renderExpression $ fromNull true null_+-- "COALESCE(NULL, TRUE)"+fromNull+ :: Expression tables grouping params ('Required ('NotNull ty))+ -- ^ what to convert @NULL@ to+ -> Expression tables grouping params ('Required ('Null ty))+ -> Expression tables grouping params ('Required ('NotNull ty))+fromNull notNullx nullx = coalesce [nullx] notNullx++-- | >>> renderExpression $ null_ & isNull+-- "NULL IS NULL"+isNull+ :: Expression tables grouping params ('Required ('Null ty))+ -- ^ possibly @NULL@+ -> Condition tables grouping params+isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"++-- | >>> renderExpression $ null_ & isn'tNull+-- "NULL IS NOT NULL"+isn'tNull+ :: Expression tables grouping params ('Required ('Null ty))+ -- ^ possibly @NULL@+ -> Condition tables grouping params+isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"++-- | analagous to `maybe` using @IS NULL@+--+-- >>> renderExpression $ matchNull true not_ null_+-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"+matchNull+ :: Expression tables grouping params ('Required nullty)+ -- ^ what to convert @NULL@ to+ -> ( Expression tables grouping params ('Required ('NotNull ty))+ -> Expression tables grouping params ('Required nullty) )+ -- ^ function to perform when @NULL@ is absent+ -> Expression tables grouping params ('Required ('Null ty))+ -> Expression tables grouping params ('Required 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+-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))+-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"+nullIf+ :: Expression tables grouping params ('Required ('NotNull ty))+ -- ^ @NULL@ is absent+ -> Expression tables grouping params ('Required ('NotNull ty))+ -- ^ @NULL@ is absent+ -> Expression tables grouping params ('Required ('Null ty))+nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized+ (renderExpression x <> ", " <> renderExpression y)++-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]+-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"+greatest+ :: Expression tables grouping params ('Required nullty)+ -- ^ needs at least 1 argument+ -> [Expression tables grouping params ('Required nullty)]+ -- ^ or more+ -> Expression tables grouping params ('Required nullty)+greatest x xs = UnsafeExpression $ "GREATEST("+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"++-- | >>> renderExpression $ least currentTimestamp [null_]+-- "LEAST(CURRENT_TIMESTAMP, NULL)"+least+ :: Expression tables grouping params ('Required nullty)+ -- ^ needs at least 1 argument+ -> [Expression tables grouping params ('Required nullty)]+ -- ^ or more+ -> Expression tables grouping params ('Required nullty)+least x xs = UnsafeExpression $ "LEAST("+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"++-- | >>> renderExpression $ unsafeBinaryOp "OR" true false+-- "(TRUE OR FALSE)"+unsafeBinaryOp+ :: ByteString+ -- ^ operator+ -> Expression tables grouping params ('Required ty0)+ -> Expression tables grouping params ('Required ty1)+ -> Expression tables grouping params ('Required ty2)+unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $+ renderExpression x <+> op <+> renderExpression y++-- | >>> renderExpression $ unsafeUnaryOp "NOT" true+-- "(NOT TRUE)"+unsafeUnaryOp+ :: ByteString+ -- ^ operator+ -> Expression tables grouping params ('Required ty0)+ -> Expression tables grouping params ('Required ty1)+unsafeUnaryOp op x = UnsafeExpression $ parenthesized $+ op <+> renderExpression x++-- | >>> renderExpression $ unsafeFunction "f" true+-- "f(TRUE)"+unsafeFunction+ :: ByteString+ -- ^ function+ -> Expression tables grouping params ('Required xty)+ -> Expression tables grouping params ('Required yty)+unsafeFunction fun x = UnsafeExpression $+ fun <> parenthesized (renderExpression x)++instance PGNum ty+ => Num (Expression tables grouping params ('Required (nullity ty))) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger+ = UnsafeExpression+ . fromString+ . show++instance (PGNum ty, PGFloating ty) => Fractional+ (Expression tables grouping params ('Required (nullity ty))) where+ (/) = unsafeBinaryOp "/"+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)++instance (PGNum ty, PGFloating ty) => Floating+ (Expression tables grouping params ('Required (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++-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ atan2_ pi 2+-- "atan2(pi(), 2)"+atan2_+ :: PGFloating float+ => Expression tables grouping params ('Required (nullity float))+ -- ^ numerator+ -> Expression tables grouping params ('Required (nullity float))+ -- ^ denominator+ -> Expression tables grouping params ('Required (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.+--+-- | >>> renderExpression $ true & cast int4+-- "(TRUE :: int4)"+cast+ :: TypeExpression ('Required ('Null ty1))+ -- ^ type to cast as+ -> Expression tables grouping params ('Required (nullity ty0))+ -- ^ value to convert+ -> Expression tables grouping params ('Required (nullity ty1))+cast ty x = UnsafeExpression $ parenthesized $+ renderExpression x <+> "::" <+> renderTypeExpression ty++-- | integer division, truncates the result+--+-- >>> renderExpression @_ @_ @_ @(_(_ 'PGint2)) $ 5 `quot_` 2+-- "(5 / 2)"+quot_+ :: PGIntegral int+ => Expression tables grouping params ('Required (nullity int))+ -- ^ numerator+ -> Expression tables grouping params ('Required (nullity int))+ -- ^ denominator+ -> Expression tables grouping params ('Required (nullity int))+quot_ = unsafeBinaryOp "/"++-- | remainder upon integer division+--+-- >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ 5 `rem_` 2+-- "(5 % 2)"+rem_+ :: PGIntegral int+ => Expression tables grouping params ('Required (nullity int))+ -- ^ numerator+ -> Expression tables grouping params ('Required (nullity int))+ -- ^ denominator+ -> Expression tables grouping params ('Required (nullity int))+rem_ = unsafeBinaryOp "%"++-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ trunc pi+-- "trunc(pi())"+trunc+ :: PGFloating frac+ => Expression tables grouping params ('Required (nullity frac))+ -- ^ fractional number+ -> Expression tables grouping params ('Required (nullity frac))+trunc = unsafeFunction "trunc"++-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ round_ pi+-- "round(pi())"+round_+ :: PGFloating frac+ => Expression tables grouping params ('Required (nullity frac))+ -- ^ fractional number+ -> Expression tables grouping params ('Required (nullity frac))+round_ = unsafeFunction "round"++-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ ceiling_ pi+-- "ceiling(pi())"+ceiling_+ :: PGFloating frac+ => Expression tables grouping params ('Required (nullity frac))+ -- ^ fractional number+ -> Expression tables grouping params ('Required (nullity frac))+ceiling_ = unsafeFunction "ceiling"++-- | A `Condition` is a boolean valued `Expression`. While SQL allows+-- conditions to have @NULL@, squeal instead chooses to disallow @NULL@,+-- forcing one to handle the case of @NULL@ explicitly to produce+-- a `Condition`.+type Condition tables grouping params =+ Expression tables grouping params ('Required ('NotNull 'PGbool))++-- | >>> renderExpression true+-- "TRUE"+true :: Condition tables grouping params+true = UnsafeExpression "TRUE"++-- | >>> renderExpression false+-- "FALSE"+false :: Condition tables grouping params+false = UnsafeExpression "FALSE"++-- | >>> renderExpression $ not_ true+-- "(NOT TRUE)"+not_+ :: Condition tables grouping params+ -> Condition tables grouping params+not_ = unsafeUnaryOp "NOT"++-- | >>> renderExpression $ true .&& false+-- "(TRUE AND FALSE)"+(.&&)+ :: Condition tables grouping params+ -> Condition tables grouping params+ -> Condition tables grouping params+(.&&) = unsafeBinaryOp "AND"++-- | >>> renderExpression $ true .|| false+-- "(TRUE OR FALSE)"+(.||)+ :: Condition tables grouping params+ -> Condition tables grouping params+ -> Condition tables grouping params+(.||) = unsafeBinaryOp "OR"++-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ caseWhenThenElse [(true, 1), (false, 2)] 3+-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"+caseWhenThenElse+ :: [ ( Condition tables grouping params+ , Expression tables grouping params ('Required ty)+ ) ]+ -> Expression tables grouping params ('Required ty)+ -> Expression tables grouping params ('Required ty)+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat+ [ "CASE"+ , mconcat+ [ mconcat+ [ " WHEN ", renderExpression when_+ , " THEN ", renderExpression then_+ ]+ | (when_,then_) <- whenThens+ ]+ , " ELSE ", renderExpression else_+ , " END"+ ]++-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ ifThenElse true 1 0+-- "CASE WHEN TRUE THEN 1 ELSE 0 END"+ifThenElse+ :: Condition tables grouping params+ -> Expression tables grouping params ('Required ty)+ -> Expression tables grouping params ('Required ty)+ -> Expression tables grouping params ('Required ty)+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_++-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`+-- will produce @NULL@s if one of their arguments is @NULL@.+--+-- >>> renderExpression $ unNull true .== null_+-- "(TRUE = NULL)"+(.==)+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs+ -> Expression tables grouping params ('Required (nullity 'PGbool))+(.==) = unsafeBinaryOp "="+infix 4 .==++-- | >>> renderExpression $ unNull true ./= null_+-- "(TRUE <> NULL)"+(./=)+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs+ -> Expression tables grouping params ('Required (nullity 'PGbool))+(./=) = unsafeBinaryOp "<>"+infix 4 ./=++-- | >>> renderExpression $ unNull true .>= null_+-- "(TRUE >= NULL)"+(.>=)+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs+ -> Expression tables grouping params ('Required (nullity 'PGbool))+(.>=) = unsafeBinaryOp ">="+infix 4 .>=++-- | >>> renderExpression $ unNull true .< null_+-- "(TRUE < NULL)"+(.<)+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs+ -> Expression tables grouping params ('Required (nullity 'PGbool))+(.<) = unsafeBinaryOp "<"+infix 4 .<++-- | >>> renderExpression $ unNull true .<= null_+-- "(TRUE <= NULL)"+(.<=)+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs+ -> Expression tables grouping params ('Required (nullity 'PGbool))+(.<=) = unsafeBinaryOp "<="+infix 4 .<=++-- | >>> renderExpression $ unNull true .> null_+-- "(TRUE > NULL)"+(.>)+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs+ -> Expression tables grouping params ('Required (nullity 'PGbool))+(.>) = unsafeBinaryOp ">"+infix 4 .>++-- | >>> renderExpression $ currentDate+-- "CURRENT_DATE"+currentDate+ :: Expression tables grouping params ('Required (nullity 'PGdate))+currentDate = UnsafeExpression "CURRENT_DATE"++-- | >>> renderExpression $ currentTime+-- "CURRENT_TIME"+currentTime+ :: Expression tables grouping params ('Required (nullity 'PGtimetz))+currentTime = UnsafeExpression "CURRENT_TIME"++-- | >>> renderExpression $ currentTimestamp+-- "CURRENT_TIMESTAMP"+currentTimestamp+ :: Expression tables grouping params ('Required (nullity 'PGtimestamptz))+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"++-- | >>> renderExpression $ localTime+-- "LOCALTIME"+localTime+ :: Expression tables grouping params ('Required (nullity 'PGtime))+localTime = UnsafeExpression "LOCALTIME"++-- | >>> renderExpression $ localTimestamp+-- "LOCALTIMESTAMP"+localTimestamp+ :: Expression tables grouping params ('Required (nullity 'PGtimestamp))+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"++{-----------------------------------------+text+-----------------------------------------}++instance IsString+ (Expression tables grouping params ('Required (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 Monoid+ (Expression tables grouping params ('Required (nullity 'PGtext))) where+ mempty = fromString ""+ mappend = unsafeBinaryOp "||"++-- | >>> renderExpression $ lower "ARRRGGG"+-- "lower(E'ARRRGGG')"+lower+ :: Expression tables grouping params ('Required (nullity 'PGtext))+ -- ^ string to lower case+ -> Expression tables grouping params ('Required (nullity 'PGtext))+lower = unsafeFunction "lower"++-- | >>> renderExpression $ upper "eeee"+-- "upper(E'eeee')"+upper+ :: Expression tables grouping params ('Required (nullity 'PGtext))+ -- ^ string to upper case+ -> Expression tables grouping params ('Required (nullity 'PGtext))+upper = unsafeFunction "upper"++-- | >>> renderExpression $ charLength "four"+-- "char_length(E'four')"+charLength+ :: Expression tables grouping params ('Required (nullity 'PGtext))+ -- ^ string to measure+ -> Expression tables grouping params ('Required (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.+--+-- >>> renderExpression $ "abc" `like` "a%"+-- "(E'abc' LIKE E'a%')"+like+ :: Expression tables grouping params ('Required (nullity 'PGtext))+ -- ^ string+ -> Expression tables grouping params ('Required (nullity 'PGtext))+ -- ^ pattern+ -> Expression tables grouping params ('Required (nullity 'PGbool))+like = unsafeBinaryOp "LIKE"++{-----------------------------------------+aggregation+-----------------------------------------}++-- | escape hatch to define aggregate functions+unsafeAggregate+ :: ByteString -- ^ aggregate function+ -> Expression tables 'Ungrouped params ('Required xty)+ -> Expression tables ('Grouped bys) params ('Required yty)+unsafeAggregate fun x = UnsafeExpression $ mconcat+ [fun, "(", renderExpression x, ")"]++-- | escape hatch to define aggregate functions over distinct values+unsafeAggregateDistinct+ :: ByteString -- ^ aggregate function+ -> Expression tables 'Ungrouped params ('Required xty)+ -> Expression tables ('Grouped bys) params ('Required yty)+unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat+ [fun, "(DISTINCT ", renderExpression x, ")"]++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sum_ #col+-- "sum(col)"+sum_+ :: PGNum ty+ => Expression tables 'Ungrouped params ('Required (nullity ty))+ -- ^ what to sum+ -> Expression tables ('Grouped bys) params ('Required (nullity ty))+sum_ = unsafeAggregate "sum"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sumDistinct #col+-- "sum(DISTINCT col)"+sumDistinct+ :: PGNum ty+ => Expression tables 'Ungrouped params ('Required (nullity ty))+ -- ^ what to sum+ -> Expression tables ('Grouped bys) params ('Required (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 tables 'Ungrouped params ('Required (nullity ty))+ -- ^ what to average+ -> Expression tables ('Grouped bys) params ('Required (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++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAnd #col+-- "bit_and(col)"+bitAnd+ :: PGIntegral int+ => Expression tables 'Ungrouped params ('Required (nullity int))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity int))+bitAnd = unsafeAggregate "bit_and"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOr #col+-- "bit_or(col)"+bitOr+ :: PGIntegral int+ => Expression tables 'Ungrouped params ('Required (nullity int))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity int))+bitOr = unsafeAggregate "bit_or"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAndDistinct #col+-- "bit_and(DISTINCT col)"+bitAndDistinct+ :: PGIntegral int+ => Expression tables 'Ungrouped params ('Required (nullity int))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity int))+bitAndDistinct = unsafeAggregateDistinct "bit_and"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOrDistinct #col+-- "bit_or(DISTINCT col)"+bitOrDistinct+ :: PGIntegral int+ => Expression tables 'Ungrouped params ('Required (nullity int))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity int))+bitOrDistinct = unsafeAggregateDistinct "bit_or"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAnd #col+-- "bool_and(col)"+boolAnd+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+boolAnd = unsafeAggregate "bool_and"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOr #col+-- "bool_or(col)"+boolOr+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+boolOr = unsafeAggregate "bool_or"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAndDistinct #col+-- "bool_and(DISTINCT col)"+boolAndDistinct+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+boolAndDistinct = unsafeAggregateDistinct "bool_and"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOrDistinct #col+-- "bool_or(DISTINCT col)"+boolOrDistinct+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+boolOrDistinct = unsafeAggregateDistinct "bool_or"++-- | A special aggregation that does not require an input+--+-- >>> renderExpression countStar+-- "count(*)"+countStar+ :: Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))+countStar = UnsafeExpression $ "count(*)"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Optional _]] $ count #col+-- "count(col)"+count+ :: Expression tables 'Ungrouped params ('Required ty)+ -- ^ what to count+ -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))+count = unsafeAggregate "count"++-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required _]] $ countDistinct #col+-- "count(DISTINCT col)"+countDistinct+ :: Expression tables 'Ungrouped params ('Required ty)+ -- ^ what to count+ -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))+countDistinct = unsafeAggregateDistinct "count"++-- | synonym for `boolAnd`+--+-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ every #col+-- "every(col)"+every+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+every = unsafeAggregate "every"++-- | synonym for `boolAndDistinct`+--+-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ everyDistinct #col+-- "every(DISTINCT col)"+everyDistinct+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))+everyDistinct = unsafeAggregateDistinct "every"++-- | minimum and maximum aggregation+max_, min_, maxDistinct, minDistinct+ :: Expression tables 'Ungrouped params ('Required (nullity ty))+ -- ^ what to aggregate+ -> Expression tables ('Grouped bys) params ('Required (nullity ty))+max_ = unsafeAggregate "max"+min_ = unsafeAggregate "min"+maxDistinct = unsafeAggregateDistinct "max"+minDistinct = unsafeAggregateDistinct "min"++{-----------------------------------------+tables+-----------------------------------------}++-- | A `Table` from a schema without its alias with an `IsLabel` instance+-- to call a table reference by its alias.+newtype Table+ (schema :: TablesType)+ (columns :: ColumnsType)+ = UnsafeTable { renderTable :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | A `HasTable` constraint indicates a table reference.+class KnownSymbol table => HasTable table tables columns+ | table tables -> columns where+ getTable :: Alias table -> Table tables columns+ getTable table = UnsafeTable $ renderAlias table+instance {-# OVERLAPPING #-} KnownSymbol table+ => HasTable table ((table ::: columns) ': tables) columns+instance {-# OVERLAPPABLE #-}+ (KnownSymbol table, HasTable table schema columns)+ => HasTable table (table' ': schema) columns++instance HasTable table schema columns+ => IsLabel table (Table schema columns) where+ fromLabel = getTable (Alias @table)++{-----------------------------------------+type expressions+-----------------------------------------}++-- | `TypeExpression`s are used in `cast`s and `createTable` commands.+newtype TypeExpression (ty :: ColumnType)+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | logical Boolean (true/false)+bool :: TypeExpression ('Required ('Null 'PGbool))+bool = UnsafeTypeExpression "bool"+-- | signed two-byte integer+int2, smallint :: TypeExpression ('Required ('Null 'PGint2))+int2 = UnsafeTypeExpression "int2"+smallint = UnsafeTypeExpression "smallint"+-- | signed four-byte integer+int4, int, integer :: TypeExpression ('Required ('Null 'PGint4))+int4 = UnsafeTypeExpression "int4"+int = UnsafeTypeExpression "int"+integer = UnsafeTypeExpression "integer"+-- | signed eight-byte integer+int8, bigint :: TypeExpression ('Required ('Null 'PGint8))+int8 = UnsafeTypeExpression "int8"+bigint = UnsafeTypeExpression "bigint"+-- | arbitrary precision numeric type+numeric :: TypeExpression ('Required ('Null 'PGnumeric))+numeric = UnsafeTypeExpression "numeric"+-- | single precision floating-point number (4 bytes)+float4, real :: TypeExpression ('Required ('Null 'PGfloat4))+float4 = UnsafeTypeExpression "float4"+real = UnsafeTypeExpression "real"+-- | double precision floating-point number (8 bytes)+float8, doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))+float8 = UnsafeTypeExpression "float8"+doublePrecision = UnsafeTypeExpression "double precision"+-- | not a true type, but merely a notational convenience for creating+-- unique identifier columns with type `'PGint2`+serial2, smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))+serial2 = UnsafeTypeExpression "serial2"+smallserial = UnsafeTypeExpression "smallserial"+-- | not a true type, but merely a notational convenience for creating+-- unique identifier columns with type `'PGint4`+serial4, serial :: TypeExpression ('Optional ('NotNull 'PGint4))+serial4 = UnsafeTypeExpression "serial4"+serial = UnsafeTypeExpression "serial"+-- | not a true type, but merely a notational convenience for creating+-- unique identifier columns with type `'PGint8`+serial8, bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))+serial8 = UnsafeTypeExpression "serial8"+bigserial = UnsafeTypeExpression "bigserial"+-- | variable-length character string+text :: TypeExpression ('Required ('Null 'PGtext))+text = UnsafeTypeExpression "text"+-- | fixed-length character string+char, character+ :: (KnownNat n, 1 <= n)+ => proxy n+ -> TypeExpression ('Required ('Null ('PGchar n)))+char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"+character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"+-- | variable-length character string+varchar, characterVarying+ :: (KnownNat n, 1 <= n)+ => proxy n+ -> TypeExpression ('Required ('Null ('PGvarchar n)))+varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"+characterVarying p = UnsafeTypeExpression $+ "character varying(" <> renderNat p <> ")"+-- | binary data ("byte array")+bytea :: TypeExpression ('Required ('Null 'PGbytea))+bytea = UnsafeTypeExpression "bytea"+-- | date and time (no time zone)+timestamp :: TypeExpression ('Required ('Null 'PGtimestamp))+timestamp = UnsafeTypeExpression "timestamp"+-- | date and time, including time zone+timestampWithTimeZone :: TypeExpression ('Required ('Null 'PGtimestamptz))+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"+-- | calendar date (year, month, day)+date :: TypeExpression ('Required ('Null 'PGdate))+date = UnsafeTypeExpression "date"+-- | time of day (no time zone)+time :: TypeExpression ('Required ('Null 'PGtime))+time = UnsafeTypeExpression "time"+-- | time of day, including time zone+timeWithTimeZone :: TypeExpression ('Required ('Null 'PGtimetz))+timeWithTimeZone = UnsafeTypeExpression "time with time zone"+-- | time span+interval :: TypeExpression ('Required ('Null 'PGinterval))+interval = UnsafeTypeExpression "interval"+-- | universally unique identifier+uuid :: TypeExpression ('Required ('Null 'PGuuid))+uuid = UnsafeTypeExpression "uuid"+-- | IPv4 or IPv6 host address+inet :: TypeExpression ('Required ('Null 'PGinet))+inet = UnsafeTypeExpression "inet"+-- | textual JSON data+json :: TypeExpression ('Required ('Null 'PGjson))+json = UnsafeTypeExpression "json"+-- | binary JSON data, decomposed+jsonb :: TypeExpression ('Required ('Null 'PGjsonb))+jsonb = UnsafeTypeExpression "jsonb"++-- | used in `createTable` commands as a column constraint to ensure+-- @NULL@ is not present+notNull+ :: TypeExpression (optionality ('Null ty))+ -> TypeExpression (optionality ('NotNull ty))+notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"++-- | used in `createTable` commands as a column constraint to give a default+default_+ :: Expression '[] 'Ungrouped '[] ('Required ty)+ -> TypeExpression ('Required ty)+ -> TypeExpression ('Optional ty)+default_ x ty = UnsafeTypeExpression $+ renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x++-- | `pgtype` is a demoted version of a `PGType`+class PGTyped (ty :: PGType) where+ pgtype :: TypeExpression ('Required ('Null ty))+instance PGTyped 'PGbool where pgtype = bool+instance PGTyped 'PGint2 where pgtype = int2+instance PGTyped 'PGint4 where pgtype = int4+instance PGTyped 'PGint8 where pgtype = int8+instance PGTyped 'PGnumeric where pgtype = numeric+instance PGTyped 'PGfloat4 where pgtype = float4+instance PGTyped 'PGfloat8 where pgtype = float8+instance PGTyped 'PGtext where pgtype = text+instance (KnownNat n, 1 <= n)+ => PGTyped ('PGchar n) where pgtype = char (Proxy @n)+instance (KnownNat n, 1 <= n)+ => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)+instance PGTyped 'PGbytea where pgtype = bytea+instance PGTyped 'PGtimestamp where pgtype = timestamp+instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone+instance PGTyped 'PGdate where pgtype = date+instance PGTyped 'PGtime where pgtype = time+instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone+instance PGTyped 'PGinterval where pgtype = interval+instance PGTyped 'PGuuid where pgtype = uuid+instance PGTyped 'PGjson where pgtype = json+instance PGTyped 'PGjsonb where pgtype = jsonb
+ src/Squeal/PostgreSQL/Manipulation.hs view
@@ -0,0 +1,368 @@+{-|+Module: Squeal.PostgreSQL.Manipulation+Description: Squeal data manipulation language+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal data manipulation language.+-}++{-# LANGUAGE+ DataKinds+ , DeriveDataTypeable+ , DeriveGeneric+ , GADTs+ , GeneralizedNewtypeDeriving+ , KindSignatures+ , LambdaCase+ , OverloadedStrings+ , RankNTypes+ , StandaloneDeriving+ , TypeInType+ , TypeOperators+#-}++module Squeal.PostgreSQL.Manipulation+ ( -- * Manipulation+ Manipulation (UnsafeManipulation, renderManipulation)+ , queryStatement+ -- * Insert+ , insertInto+ , ValuesClause (Values, ValuesQuery)+ , renderValuesClause+ , ReturningClause (ReturningStar, Returning)+ , renderReturningClause+ , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)+ , renderConflictClause+ -- * Update+ , update+ , UpdateExpression (Same, Set)+ , renderUpdateExpression+ , deleteFrom+ ) where++import Control.DeepSeq+import Data.ByteString+import Data.Monoid++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Prettyprint+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Schema++-- | A `Manipulation` is a statement which may modify data in the database,+-- but does not alter the schema. Examples are `insertInto`, `update` and+-- `deleteFrom`. A `Query` is also considered a `Manipulation` even though+-- it does not modify data.+newtype Manipulation+ (schema :: TablesType)+ (params :: [ColumnType])+ (columns :: ColumnsType)+ = UnsafeManipulation { renderManipulation :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | Convert a `Query` into a `Manipulation`.+queryStatement+ :: Query schema params columns+ -> Manipulation schema params columns+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"++{-----------------------------------------+INSERT statements+-----------------------------------------}++{- |+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.++simple insert:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]+ manipulation =+ insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])+ OnConflictDoRaise (Returning Nil)+in renderManipulation manipulation+:}+"INSERT INTO tab (col1, col2) VALUES (2, 4);"++parameterized insert:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]+ '[ 'Required ('NotNull 'PGint4)+ , 'Required ('NotNull 'PGint4) ] '[]+ manipulation =+ insertInto #tab+ (Values (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) [])+ OnConflictDoRaise (Returning Nil)+in renderManipulation manipulation+:}+"INSERT INTO tab (col1, col2) VALUES (($1 :: int4), ($2 :: int4));"++returning insert:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]+ '["fromOnly" ::: 'Required ('NotNull 'PGint4)]+ manipulation =+ insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])+ OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))+in renderManipulation manipulation+:}+"INSERT INTO tab (col1, col2) VALUES (2, 4) RETURNING col1 AS fromOnly;"++query insert:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4)+ ]+ , "other_tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4)+ ]+ ] '[] '[]+ manipulation = + insertInto #tab+ ( ValuesQuery $+ selectStar (from (Table (#other_tab `As` #t))) )+ OnConflictDoRaise (Returning Nil)+in renderManipulation manipulation+:}+"INSERT INTO tab SELECT * FROM other_tab AS t;"++upsert:++>>> :{+let+ manipulation :: Manipulation+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]+ '[] '[ "sum" ::: 'Required ('NotNull 'PGint4)]+ manipulation =+ insertInto #tab+ (Values+ (2 `As` #col1 :* 4 `As` #col2 :* Nil)+ [6 `As` #col1 :* 8 `As` #col2 :* Nil])+ (OnConflictDoUpdate+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+ (Just (#col1 .== #col2)))+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)+in renderManipulation 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;"+-}+insertInto+ :: (SOP.SListI columns, SOP.SListI results, HasTable table schema columns)+ => Alias table -- ^ table to insert into+ -> ValuesClause schema params columns -- ^ values to insert+ -> ConflictClause columns params+ -- ^ what to do in case of constraint conflict+ -> ReturningClause columns params results -- ^ results to return+ -> Manipulation schema params results+insertInto table insert conflict returning = UnsafeManipulation $+ "INSERT" <+> "INTO" <+> renderAlias table+ <+> renderValuesClause insert+ <> renderConflictClause conflict+ <> renderReturningClause returning++-- | A `ValuesClause` lets you insert either values, free `Expression`s,+-- or the result of a `Query`.+data ValuesClause+ (schema :: TablesType)+ (params :: [ColumnType])+ (columns :: ColumnsType)+ = Values+ (NP (Aliased (Expression '[] 'Ungrouped params)) columns)+ [NP (Aliased (Expression '[] 'Ungrouped params)) columns]+ -- ^ at least one row of values+ | ValuesQuery (Query schema params columns)++-- | Render a `ValuesClause`.+renderValuesClause+ :: SOP.SListI columns+ => ValuesClause schema params columns+ -> ByteString+renderValuesClause = \case+ Values row rows ->+ parenthesized (renderCommaSeparated renderAliasPart row)+ <+> "VALUES"+ <+> commaSeparated+ (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)+ where+ renderAliasPart, renderValuePart+ :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString+ renderAliasPart (_ `As` name) = renderAlias name+ renderValuePart (value `As` _) = renderExpression value+ ValuesQuery q -> renderQuery q++-- | A `ReturningClause` computes and return value(s) based+-- on each row actually inserted, updated or deleted. This is primarily+-- useful for obtaining values that were supplied by defaults, such as a+-- serial sequence number. However, any expression using the table's columns+-- 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+-- in the row. Use `Returning Nil` in the common case where no return+-- values are desired.+data ReturningClause+ (columns :: ColumnsType)+ (params :: [ColumnType])+ (results :: ColumnsType)+ where+ ReturningStar :: ReturningClause columns params columns+ Returning+ :: NP+ (Aliased (Expression '[table ::: columns] 'Ungrouped params))+ results+ -> ReturningClause columns params results++-- | Render a `ReturningClause`.+renderReturningClause+ :: SOP.SListI results+ => ReturningClause params columns results+ -> ByteString+renderReturningClause = \case+ ReturningStar -> " RETURNING *;"+ Returning Nil -> ";"+ Returning results -> " RETURNING"+ <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"++-- | 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+-- proposed for insertion.+data ConflictClause columns params where+ OnConflictDoRaise :: ConflictClause columns params+ OnConflictDoNothing :: ConflictClause columns params+ OnConflictDoUpdate+ :: NP (Aliased (UpdateExpression columns params)) columns+ -> Maybe (Condition '[table ::: columns] 'Ungrouped params)+ -> ConflictClause columns params++-- | Render a `ConflictClause`.+renderConflictClause+ :: SOP.SListI columns+ => ConflictClause columns params+ -> ByteString+renderConflictClause = \case+ OnConflictDoRaise -> ""+ OnConflictDoNothing -> " ON CONFLICT DO NOTHING"+ OnConflictDoUpdate updates whMaybe+ -> " ON CONFLICT DO UPDATE SET"+ <+> renderCommaSeparatedMaybe renderUpdateExpression updates+ <> case whMaybe of+ Nothing -> ""+ Just wh -> " WHERE" <+> renderExpression wh++{-----------------------------------------+UPDATE statements+-----------------------------------------}++-- | An `update` command changes the values of the specified columns+-- in all rows that satisfy the condition.+--+-- >>> :{+-- let+-- manipulation :: Manipulation+-- '[ "tab" :::+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]+-- manipulation =+-- update #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+-- (#col1 ./= #col2) (Returning Nil)+-- in renderManipulation manipulation+-- :}+-- "UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"+update+ :: (HasTable table schema columns, SOP.SListI columns, SOP.SListI results)+ => Alias table -- ^ table to update+ -> NP (Aliased (UpdateExpression columns params)) columns+ -- ^ modified values to replace old values+ -> Condition '[tab ::: columns] 'Ungrouped params+ -- ^ condition under which to perform update on a row+ -> ReturningClause columns params results -- ^ results to return+ -> Manipulation schema params results+update table columns wh returning = UnsafeManipulation $+ "UPDATE"+ <+> renderAlias table+ <+> "SET"+ <+> renderCommaSeparatedMaybe renderUpdateExpression columns+ <+> "WHERE" <+> renderExpression wh+ <> renderReturningClause returning++-- | Columns to be updated are mentioned with `Set`; columns which are to+-- remain the same are mentioned with `Same`.+data UpdateExpression columns params ty+ = Same+ -- ^ column to remain the same upon update+ | Set (forall table. Expression '[table ::: columns] 'Ungrouped params ty)+ -- ^ column to be updated+deriving instance Show (UpdateExpression columns params ty)+deriving instance Eq (UpdateExpression columns params ty)+deriving instance Ord (UpdateExpression columns params ty)++-- | Render an `UpdateExpression`.+renderUpdateExpression+ :: Aliased (UpdateExpression params columns) column+ -> Maybe ByteString+renderUpdateExpression = \case+ Same `As` _ -> Nothing+ Set expression `As` column -> Just $+ renderAlias column <+> "=" <+> renderExpression expression++{-----------------------------------------+DELETE statements+-----------------------------------------}++-- | Delete rows of a table.+--+-- >>> :{+-- let+-- manipulation :: Manipulation+-- '[ "tab" :::+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]+-- manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar+-- in renderManipulation manipulation+-- :}+-- "DELETE FROM tab WHERE (col1 = col2) RETURNING *;"+deleteFrom+ :: (SOP.SListI results, HasTable table schema columns)+ => Alias table -- ^ table to delete from+ -> Condition '[table ::: columns] 'Ungrouped params+ -- ^ condition under which to delete a row+ -> ReturningClause columns params results -- ^ results to return+ -> Manipulation schema params results+deleteFrom table wh returning = UnsafeManipulation $+ "DELETE FROM" <+> renderAlias table+ <+> "WHERE" <+> renderExpression wh+ <> renderReturningClause returning
+ src/Squeal/PostgreSQL/PQ.hs view
@@ -0,0 +1,575 @@+{-|+Module: Squeal.PostgreSQL.PQ+Description: PQ monad+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++`Squeal.PostgreSQL.PQ` is where Squeal statements come to actually get run by+`LibPQ`. It contains a `PQ` indexed monad transformer to run `Definition`s and+a `MonadPQ` constraint for running a `Manipulation` or `Query`.+-}++{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# LANGUAGE+ DataKinds+ , DefaultSignatures+ , FunctionalDependencies+ , PolyKinds+ , DeriveFunctor+ , FlexibleContexts+ , FlexibleInstances+ , MagicHash+ , MultiParamTypeClasses+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.PQ+ ( -- * Connection+ Connection (unConnection)+ , connectdb+ , finish+ , withConnection+ -- * PQ+ , PQ (runPQ)+ , execPQ+ , pqAp+ , pqBind+ , pqThen+ , define+ , thenDefine+ -- * MonadPQ+ , MonadPQ (..)+ , PQRun+ , pqliftWith+ -- * Result+ , Result (Result, unResult)+ , RowNumber (RowNumber, unRowNumber)+ , ColumnNumber (UnsafeColumnNumber, getColumnNumber)+ , HasColumnNumber (columnNumber)+ , getValue+ , getRow+ , getRows+ , ntuples+ , nextRow+ , firstRow+ , liftResult+ ) where++import Control.Exception.Lifted+import Control.Monad.Base+import Control.Monad.Except+import Control.Monad.Trans.Control+import Data.ByteString (ByteString)+import Data.Foldable+import Data.Function ((&))+import Data.Kind+import Data.Monoid+import Data.Traversable+import Generics.SOP+import GHC.Exts hiding (fromList)+import GHC.TypeLits++import qualified Database.PostgreSQL.LibPQ as LibPQ++import Squeal.PostgreSQL.Binary+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Schema++-- For `MonadPQ` transformer instances+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Cont+import Control.Monad.Trans.List++import qualified Control.Monad.Trans.State.Lazy as Lazy+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Lazy as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict+import qualified Control.Monad.Trans.RWS.Lazy as Lazy+import qualified Control.Monad.Trans.RWS.Strict as Strict++-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`+-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`+newtype Connection (schema :: TablesType) =+ Connection { unConnection :: LibPQ.Connection }++{- | Makes a new connection to the database server.++This function opens a new database connection using the parameters taken+from the string conninfo.++The passed string can be empty to use all default parameters, or it can+contain one or more parameter settings separated by whitespace.+Each parameter setting is in the form keyword = value. Spaces around the equal+sign are optional. To write an empty value or a value containing spaces,+surround it with single quotes, e.g., keyword = 'a value'. Single quotes and+backslashes within the value must be escaped with a backslash, i.e., ' and \.++To specify the schema you wish to connect with, use type application.++>>> :set -XDataKinds+>>> :set -XTypeOperators+>>> type Schema = '["tab" ::: '["col" ::: 'Required ('Null 'PGint2)]]+>>> :set -XTypeApplications+>>> :set -XOverloadedStrings+>>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"++Note that, for now, squeal doesn't offer any protection from connecting+with the wrong schema!+-}+connectdb+ :: forall schema io+ . MonadBase IO io+ => ByteString -- ^ conninfo+ -> io (Connection schema)+connectdb = fmap Connection . liftBase . LibPQ.connectdb++-- | Closes the connection to the server.+finish :: MonadBase IO io => Connection schema -> io ()+finish = liftBase . LibPQ.finish . unConnection++-- | Do `connectdb` and `finish` before and after a computation.+withConnection+ :: forall schema io x+ . MonadBaseControl IO io+ => ByteString+ -> (Connection schema -> io x)+ -> io x+withConnection connString = bracket (connectdb connString) finish+++-- | We keep track of the schema via an Atkey indexed state monad transformer,+-- `PQ`.+newtype PQ+ (schema0 :: TablesType)+ (schema1 :: TablesType)+ (m :: Type -> Type)+ (x :: Type) =+ PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }+ deriving Functor++-- | Run a `PQ` and discard the result but keep the `Connection`. +execPQ+ :: Functor m+ => PQ schema0 schema1 m x+ -> Connection schema0+ -> m (Connection schema1)+execPQ (PQ pq) = fmap snd . pq++-- | indexed analog of `<*>`+pqAp+ :: Monad m+ => PQ schema0 schema1 m (x -> y)+ -> PQ schema1 schema2 m x+ -> PQ schema0 schema2 m y+pqAp (PQ f) (PQ x) = PQ $ \ conn -> do+ (f', conn') <- f conn+ (x', conn'') <- x conn'+ return (f' x', conn'')++-- | indexed analog of `=<<`+pqBind+ :: Monad m+ => (x -> PQ schema1 schema2 m y)+ -> PQ schema0 schema1 m x+ -> PQ schema0 schema2 m y+pqBind f (PQ x) = PQ $ \ conn -> do+ (x', conn') <- x conn+ runPQ (f x') conn'++-- | indexed analog of flipped `>>`+pqThen+ :: Monad m+ => PQ schema1 schema2 m y+ -> PQ schema0 schema1 m x+ -> PQ schema0 schema2 m y+pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)++-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law+--+-- @pqThen (define statement2) statement1 = define (statement2 . statement1)@+define+ :: MonadBase IO io+ => Definition schema0 schema1+ -> PQ schema0 schema1 io (Result '[])+define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do+ resultMaybe <- liftBase $ LibPQ.exec conn q+ case resultMaybe of+ Nothing -> error+ "define: LibPQ.exec returned no results"+ Just result -> return (Result result, Connection conn)++-- | Chain together `define` actions.+thenDefine+ :: MonadBase IO io+ => Definition schema1 schema2+ -> PQ schema0 schema1 io x+ -> PQ schema0 schema2 io (Result '[])+thenDefine = pqThen . define++{- | `MonadPQ` is an `mtl` style constraint, similar to+`Control.Monad.State.Class.MonadState`, for using `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.++* `manipulate` is like `manipulateParams` for a parameter-free statement.++* `runQueryParams` is like `manipulateParams` for query statements.++* `traversePrepared` has the same type signature as a composition of+ `traverse` and `manipulateParams` but provides an optimization by+ preparing the statement with `LibPQ.prepare` and then traversing a+ `Traversable` container with `LibPQ.execPrepared`. The temporary prepared+ statement is then deallocated.++* `forPrepared` is a flipped `traversePrepared`++* `traversePrepared_` is like `traversePrepared` but works on `Foldable`+ containers and returns unit.++* `forPrepared_` is a flipped `traversePrepared_`.++* `liftPQ` lets you lift actions from `LibPQ` that require a connection+ into your monad.++To define an instance, you can minimally define only `manipulateParams`,+`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get+a default instance.++-}+class Monad pq => MonadPQ schema pq | pq -> schema where+ manipulateParams+ :: ToParams x params+ => Manipulation schema params ys+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> x -> pq (Result ys)+ default manipulateParams+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ => ToParams x params+ => Manipulation schema params ys+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> x -> pq (Result ys)+ manipulateParams manipulation params = lift $+ manipulateParams manipulation params++ manipulate :: Manipulation schema '[] ys -> pq (Result ys)+ manipulate statement = manipulateParams statement ()++ runQueryParams+ :: ToParams x params+ => Query schema params ys+ -- ^ `select` and friends+ -> x -> pq (Result ys)+ runQueryParams = manipulateParams . queryStatement++ runQuery+ :: Query schema '[] ys+ -- ^ `select` and friends+ -> pq (Result ys)+ runQuery q = runQueryParams q ()++ traversePrepared+ :: (ToParams x params, Traversable list)+ => Manipulation schema params ys+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> list x -> pq (list (Result ys))+ default traversePrepared+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ => (ToParams x params, Traversable list)+ => Manipulation schema params ys -> list x -> pq (list (Result ys))+ traversePrepared manipulation params = lift $+ traversePrepared manipulation params++ forPrepared+ :: (ToParams x params, Traversable list)+ => list x+ -> Manipulation schema params ys+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> pq (list (Result ys))+ forPrepared = flip traversePrepared++ traversePrepared_+ :: (ToParams x params, Foldable list)+ => Manipulation schema params '[]+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> list x -> pq ()+ default traversePrepared_+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)+ => (ToParams x params, Foldable list)+ => Manipulation schema params '[]+ -- ^ `insertInto`, `update` or `deleteFrom`+ -> list x -> pq ()+ traversePrepared_ manipulation params = lift $+ traversePrepared_ manipulation params++ forPrepared_+ :: (ToParams x params, Traversable list)+ => list x+ -> Manipulation schema 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)+ => (LibPQ.Connection -> IO a) -> pq a+ liftPQ = lift . liftPQ++instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where++ manipulateParams+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =+ PQ $ \ (Connection conn) -> do+ let+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary+ case resultMaybe of+ Nothing -> error+ "manipulateParams: LibPQ.execParams returned no results"+ Just result -> return (Result result, Connection conn)++ traversePrepared+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =+ PQ $ \ (Connection conn) -> liftBase $ do+ let temp = "temporary_statement"+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing+ case prepResultMaybe of+ Nothing -> error+ "traversePrepared: LibPQ.prepare returned no results"+ Just prepResult -> do+ status <- LibPQ.resultStatus prepResult+ unless (status == LibPQ.CommandOk) . error $+ "traversePrepared: LibPQ.prepare status " <> show status+ results <- for list $ \ params -> do+ let+ toParam' bytes = (bytes,LibPQ.Binary)+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary+ case resultMaybe of+ Nothing -> error+ "traversePrepared: LibPQ.execParams returned no results"+ Just result -> return $ Result result+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")+ case deallocResultMaybe of+ Nothing -> error+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"+ Just deallocResult -> do+ status <- LibPQ.resultStatus deallocResult+ unless (status == LibPQ.CommandOk) . error $+ "traversePrepared: DEALLOCATE status " <> show status+ return (results, Connection conn)++ traversePrepared_+ (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =+ PQ $ \ (Connection conn) -> liftBase $ do+ let temp = "temporary_statement"+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing+ case prepResultMaybe of+ Nothing -> error+ "traversePrepared_: LibPQ.prepare returned no results"+ Just prepResult -> do+ status <- LibPQ.resultStatus prepResult+ unless (status == LibPQ.CommandOk) . error $+ "traversePrepared: LibPQ.prepare status " <> show status+ for_ list $ \ params -> do+ let+ toParam' bytes = (bytes,LibPQ.Binary)+ params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary+ case resultMaybe of+ Nothing -> error+ "traversePrepared_: LibPQ.execParams returned no results"+ Just _result -> return ()+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")+ case deallocResultMaybe of+ Nothing -> error+ "traversePrepared: LibPQ.exec DEALLOCATE returned no results"+ Just deallocResult -> do+ status <- LibPQ.resultStatus deallocResult+ unless (status == LibPQ.CommandOk) . error $+ "traversePrepared: DEALLOCATE status " <> show status+ return ((), Connection conn)++ liftPQ pq = PQ $ \ (Connection conn) -> do+ y <- liftBase $ pq conn+ return (y, Connection conn)++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 schema m => MonadPQ schema (ListT m)++instance Monad m => Applicative (PQ schema schema m) where+ pure x = PQ $ \ conn -> pure (x, conn)+ (<*>) = pqAp++instance Monad m => Monad (PQ schema schema m) where+ return = pure+ (>>=) = flip pqBind++instance MonadTrans (PQ schema schema) where+ lift m = PQ $ \ conn -> do+ x <- m+ return (x, conn)++instance MonadBase b m => MonadBase b (PQ schema schema 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 (x, Connection 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 (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)++instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where+ type StM (PQ schema schema m) x = StM m (x, Connection schema)+ liftBaseWith f =+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run+ restoreM = PQ . const . restoreM++-- | Encapsulates the result of a squeal command run by @LibPQ@.+-- `Result`s are parameterized by a `ColumnsType` describing the column names+-- and their types.+newtype Result (columns :: ColumnsType)+ = Result { unResult :: LibPQ.Result }++-- | Just newtypes around a `CInt`+newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }++-- | In addition to being newtypes around a `CInt`, a `ColumnNumber` is+-- parameterized by a `Nat`ural number and acts as an index into a row.+newtype ColumnNumber (n :: Nat) (cs :: [k]) (c :: k) =+ UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }++-- | >>> getColumnNumber (columnNumber @5 @'[_,_,_,_,_,_])+-- Col 5+class KnownNat n => HasColumnNumber n columns column+ | n columns -> column where+ columnNumber :: ColumnNumber n columns column+ columnNumber =+ UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)+instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1+instance {-# OVERLAPPABLE #-}+ (KnownNat n, HasColumnNumber (n-1) columns column)+ => HasColumnNumber n (column' : columns) column++-- | Get a single value corresponding to a given row and column number+-- from a `Result`.+getValue+ :: (FromColumnValue colty y, MonadBase IO io)+ => RowNumber -- ^ row+ -> ColumnNumber n columns colty -- ^ col+ -> Result columns -- ^ result+ -> io y+getValue+ (RowNumber r)+ (UnsafeColumnNumber c :: ColumnNumber n columns colty)+ (Result result)+ = fmap (fromColumnValue @colty . K) $ liftBase $ do+ numRows <- LibPQ.ntuples result+ when (numRows < r) $ error $+ "getValue: expected at least " <> show r <> "rows but only saw "+ <> show numRows+ LibPQ.getvalue result r c++-- | Get a row corresponding to a given row number from a `Result`.+getRow+ :: (FromRow columns y, MonadBase IO io)+ => RowNumber+ -- ^ row+ -> Result columns+ -- ^ result+ -> io y+getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do+ numRows <- LibPQ.ntuples result+ when (numRows < r) $ error $+ "getRow: expected at least " <> show r <> "rows but only saw "+ <> show numRows+ let len = fromIntegral (lengthSList (Proxy @columns))+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]+ case fromList row' of+ Nothing -> error "getRow: found unexpected length"+ Just row -> return $ fromRow @columns row++-- | Returns the number of rows (tuples) in the query result.+ntuples :: MonadBase IO io => Result columns -> io RowNumber+ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result++-- | Intended to be used for unfolding in streaming libraries, `nextRow`+-- takes a total number of rows (which can be found with `ntuples`)+-- and a `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)+ => RowNumber -- ^ total number of rows+ -> Result columns -- ^ result+ -> RowNumber -- ^ row number+ -> io (Maybe (RowNumber,y))+nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)+ = liftBase $ 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+ Nothing -> error "nextRow: found unexpected length"+ Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)++-- | Get all rows from a `Result`.+getRows+ :: (FromRow columns y, MonadBase IO io)+ => Result columns -- ^ result+ -> io [y]+getRows (Result result :: Result columns) = liftBase $ do+ let len = fromIntegral (lengthSList (Proxy @columns))+ numRows <- LibPQ.ntuples result+ for [0 .. numRows - 1] $ \ r -> do+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]+ case fromList row' of+ Nothing -> error "getRows: found unexpected length"+ Just row -> return $ fromRow @columns row++-- | Get the first row if possible from a `Result`.+firstRow+ :: (FromRow columns y, MonadBase IO io)+ => Result columns -- ^ result+ -> io (Maybe y)+firstRow (Result result :: Result columns) = liftBase $ do+ numRows <- LibPQ.ntuples result+ if numRows <= 0 then return Nothing else do+ let len = fromIntegral (lengthSList (Proxy @columns))+ row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]+ case fromList row' of+ Nothing -> error "firstRow: found unexpected length"+ Just row -> return . Just $ fromRow @columns row++-- | Lifts actions on results from `LibPQ`.+liftResult+ :: MonadBase IO io+ => (LibPQ.Result -> IO x)+ -> Result results -> io x+liftResult f (Result result) = liftBase $ f result
+ src/Squeal/PostgreSQL/Prettyprint.hs view
@@ -0,0 +1,67 @@+{-|+Module: Squeal.PostgreSQL.PrettyPrint+Description: Pretty print helper functions+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Pretty print helper functions.+-}++{-# LANGUAGE+ MagicHash+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+#-}++module Squeal.PostgreSQL.Prettyprint where++import Data.ByteString (ByteString)+import Data.Maybe+import Data.Monoid ((<>))+import Generics.SOP+import GHC.Exts+import GHC.TypeLits++import qualified Data.ByteString as ByteString++-- | Parenthesize a `ByteString`.+parenthesized :: ByteString -> ByteString+parenthesized str = "(" <> str <> ")"++-- | Concatenate two `ByteString`s with a space between.+(<+>) :: ByteString -> ByteString -> ByteString+str1 <+> str2 = str1 <> " " <> str2++-- | Comma separate a list of `ByteString`s.+commaSeparated :: [ByteString] -> ByteString+commaSeparated = ByteString.intercalate ", "++-- | Comma separate the renderings of a heterogeneous list.+renderCommaSeparated+ :: SListI xs+ => (forall x. expression x -> ByteString)+ -> NP expression xs -> ByteString+renderCommaSeparated render+ = commaSeparated+ . hcollapse+ . hmap (K . render)++-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping+-- `Nothing`s.+renderCommaSeparatedMaybe+ :: SListI xs+ => (forall x. expression x -> Maybe ByteString)+ -> NP expression xs -> ByteString+renderCommaSeparatedMaybe render+ = commaSeparated+ . catMaybes+ . hcollapse+ . hmap (K . render)++-- | Render a promoted `Nat`.+renderNat :: KnownNat n => proxy n -> ByteString+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
+ src/Squeal/PostgreSQL/Query.hs view
@@ -0,0 +1,775 @@+{-|+Module: Squeal.PostgreSQL.Query+Description: Squeal queries+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal queries.+-}++{-# LANGUAGE+ DataKinds+ , DeriveDataTypeable+ , DeriveGeneric+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , KindSignatures+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeInType+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Query+ ( -- * Queries+ Query (UnsafeQuery, renderQuery)+ , union+ , unionAll+ , intersect+ , intersectAll+ , except+ , exceptAll+ -- * Select+ , select+ , selectDistinct+ , selectStar+ , selectDistinctStar+ , selectDotStar+ , selectDistinctDotStar+ -- * Table Expressions+ , TableExpression (..)+ , renderTableExpression+ , from+ , where_+ , group+ , having+ , orderBy+ , limit+ , offset+ -- * From+ , FromClause (..)+ , renderFromClause+ -- * Grouping+ , By (By, By2)+ , renderBy+ , GroupByClause (NoGroups, Group)+ , renderGroupByClause+ , HavingClause (NoHaving, Having)+ , renderHavingClause+ -- * Sorting+ , SortExpression (..)+ , renderSortExpression+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.Monoid+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.Prettyprint+import Squeal.PostgreSQL.Schema++{- |+The process of retrieving or the command to retrieve data from a database+is called a `Query`. The `select`, `selectStar`, `selectDotStar`,+`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands+are used to specify queries.++simple query:++>>> :{+let+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]+ '["col" ::: 'Required ('Null 'PGint4)]+ query = selectStar (from (Table (#tab `As` #t)))+in renderQuery query+:}+"SELECT * FROM tab AS t"++restricted query:++>>> :{+let+ query :: Query+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]+ '[]+ '[ "sum" ::: 'Required ('NotNull 'PGint4)+ , "col1" ::: 'Required ('NotNull 'PGint4) ]+ query = + select+ ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ ( from (Table (#tab `As` #t))+ & where_ (#col1 .> #col2)+ & where_ (#col2 .> 0) )+in renderQuery query+:}+"SELECT (col1 + col2) AS sum, col1 AS col1 FROM tab AS t WHERE ((col1 > col2) AND (col2 > 0))"++subquery:++>>> :{+let+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]+ '["col" ::: 'Required ('Null 'PGint4)]+ query =+ selectStar+ (from (Subquery (selectStar (from (Table (#tab `As` #t))) `As` #sub)))+in renderQuery query+:}+"SELECT * FROM (SELECT * FROM tab AS t) AS sub"++limits and offsets:++>>> :{+let+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]+ '["col" ::: 'Required ('Null 'PGint4)]+ query = selectStar+ (from (Table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)+in renderQuery query+:}+"SELECT * FROM tab AS t LIMIT 50 OFFSET 4"++parameterized query:++>>> :{+let+ query :: Query '["tab" ::: '["col" ::: 'Required ('NotNull 'PGfloat8)]]+ '[ 'Required ('NotNull 'PGfloat8)]+ '["col" ::: 'Required ('NotNull 'PGfloat8)]+ query = selectStar+ (from (Table (#tab `As` #t)) & where_ (#col .> param @1))+in renderQuery query+:}+"SELECT * FROM tab AS t WHERE (col > ($1 :: float8))"++aggregation query:++>>> :{+let+ query :: Query+ '[ "tab" :::+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]+ '[]+ '[ "sum" ::: 'Required ('NotNull 'PGint4)+ , "col1" ::: 'Required ('NotNull 'PGint4) ]+ query =+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)+ ( from (Table (#tab `As` #table1))+ & group (By #col1 :* Nil) + & having (#col1 + sum_ #col2 .> 1) )+in renderQuery 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" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]+ '["col" ::: 'Required ('Null 'PGint4)]+ query = selectStar+ (from (Table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])+in renderQuery query+:}+"SELECT * FROM tab AS t ORDER BY col ASC NULLS FIRST"++joins:++>>> :set -XFlexibleContexts+>>> :{+let+ query :: Query+ '[ "orders" :::+ '[ "id" ::: 'Required ('NotNull 'PGint4)+ , "price" ::: 'Required ('NotNull 'PGfloat4)+ , "customer_id" ::: 'Required ('NotNull 'PGint4)+ , "shipper_id" ::: 'Required ('NotNull 'PGint4)+ ]+ , "customers" :::+ '[ "id" ::: 'Required ('NotNull 'PGint4)+ , "name" ::: 'Required ('NotNull 'PGtext)+ ]+ , "shippers" :::+ '[ "id" ::: 'Required ('NotNull 'PGint4)+ , "name" ::: 'Required ('NotNull 'PGtext)+ ]+ ]+ '[]+ '[ "order_price" ::: 'Required ('NotNull 'PGfloat4)+ , "customer_name" ::: 'Required ('NotNull 'PGtext)+ , "shipper_name" ::: 'Required ('NotNull 'PGtext)+ ]+ query = select+ ( #o ! #price `As` #order_price :*+ #c ! #name `As` #customer_name :*+ #s ! #name `As` #shipper_name :* Nil )+ ( 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 renderQuery 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" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]+ '["col" ::: 'Required ('Null 'PGint4)]+ query = selectDotStar #t1+ (from (Table (#tab `As` #t1) & CrossJoin (Table (#tab `As` #t2))))+in renderQuery query+:}+"SELECT t1.* FROM tab AS t1 CROSS JOIN tab AS t2"++set operations:++>>> :{+let+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]+ '["col" ::: 'Required ('Null 'PGint4)]+ query =+ selectStar (from (Table (#tab `As` #t)))+ `unionAll`+ selectStar (from (Table (#tab `As` #t)))+in renderQuery query+:}+"(SELECT * FROM tab AS t) UNION ALL (SELECT * FROM tab AS t)"+-}++newtype Query+ (schema :: TablesType)+ (params :: [ColumnType])+ (columns :: ColumnsType)+ = UnsafeQuery { renderQuery :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | 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 tables grouping params)) (column ': columns)+ -- ^ select list+ -> TableExpression schema params tables grouping+ -- ^ intermediate virtual table+ -> Query schema params (column ': columns)+select list tabs = UnsafeQuery $+ "SELECT"+ <+> renderCommaSeparated (renderAliased renderExpression) list+ <+> renderTableExpression tabs++-- | 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 tables 'Ungrouped params)) (column ': columns)+ -- ^ select list+ -> TableExpression schema params tables 'Ungrouped+ -- ^ intermediate virtual table+ -> Query schema params (column ': columns)+selectDistinct list tabs = UnsafeQuery $+ "SELECT DISTINCT"+ <+> renderCommaSeparated (renderAliased renderExpression) list+ <+> renderTableExpression tabs++-- | The simplest kind of query is `selectStar` which emits all columns+-- that the table expression produces.+selectStar+ :: HasUnique table tables columns+ => TableExpression schema params tables 'Ungrouped+ -- ^ intermediate virtual table+ -> Query schema params columns+selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs++-- | A `selectDistinctStar` emits all columns that the table expression+-- produces and eliminates duplicate rows.+selectDistinctStar+ :: HasUnique table tables columns+ => TableExpression schema params tables 'Ungrouped+ -- ^ intermediate virtual table+ -> Query schema params columns+selectDistinctStar tabs = UnsafeQuery $+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs++-- | When working with multiple tables, it can also be useful to ask+-- for all the columns of a particular table, using `selectDotStar`.+selectDotStar+ :: HasTable table tables columns+ => Alias table+ -- ^ particular virtual subtable+ -> TableExpression schema params tables 'Ungrouped+ -- ^ intermediate virtual table+ -> Query schema params columns+selectDotStar table tables = UnsafeQuery $+ "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables++-- | A `selectDistinctDotStar` asks for all the columns of a particular table, +-- and eliminates duplicate rows.+selectDistinctDotStar+ :: HasTable table tables columns+ => Alias table+ -- ^ particular virtual subtable+ -> TableExpression schema params tables 'Ungrouped+ -- ^ intermediate virtual table+ -> Query schema params columns+selectDistinctDotStar table tables = UnsafeQuery $+ "SELECT DISTINCT" <+> renderAlias table <> ".*"+ <+> renderTableExpression tables++{-----------------------------------------+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 :: TablesType)+ (params :: [ColumnType])+ (tables :: TablesType)+ (grouping :: Grouping)+ = TableExpression+ { fromClause :: FromClause schema params tables+ -- ^ 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 tables '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 tables 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 tables 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 tables 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 tables grouping+ -> ByteString+renderTableExpression+ (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat+ [ "FROM ", renderFromClause tables+ , 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 tables -- ^ table reference+ -> TableExpression schema params tables 'Ungrouped+from tables = TableExpression tables [] NoGroups NoHaving [] [] []++-- | A `where_` is an endomorphism of `TableExpression`s which adds a+-- search condition to the `whereClause`.+where_+ :: Condition tables 'Ungrouped params+ -> TableExpression schema params tables grouping+ -> TableExpression schema params tables grouping+where_ wh tables = tables {whereClause = wh : whereClause tables}++-- | A `group` is a transformation of `TableExpression`s which switches+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform+-- a "grand total" aggregation query.+group+ :: SListI bys+ => NP (By tables) bys+ -> TableExpression schema params tables 'Ungrouped + -> TableExpression schema params tables ('Grouped bys)+group bys tables = TableExpression+ { fromClause = fromClause tables+ , whereClause = whereClause tables+ , groupByClause = Group bys+ , havingClause = Having []+ , orderByClause = []+ , limitClause = limitClause tables+ , offsetClause = offsetClause tables+ }++-- | A `having` is an endomorphism of `TableExpression`s which adds a+-- search condition to the `havingClause`.+having+ :: Condition tables ('Grouped bys) params+ -> TableExpression schema params tables ('Grouped bys)+ -> TableExpression schema params tables ('Grouped bys)+having hv tables = tables+ { havingClause = case havingClause tables 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 tables grouping params]+ -> TableExpression schema params tables grouping+ -> TableExpression schema params tables grouping+orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}++-- | A `limit` is an endomorphism of `TableExpression`s which adds to the+-- `limitClause`.+limit+ :: Word64+ -> TableExpression schema params tables grouping+ -> TableExpression schema params tables grouping+limit lim tables = tables {limitClause = lim : limitClause tables}++-- | An `offset` is an endomorphism of `TableExpression`s which adds to the+-- `offsetClause`.+offset+ :: Word64+ -> TableExpression schema params tables grouping+ -> TableExpression schema params tables grouping+offset off tables = tables {offsetClause = off : offsetClause tables}++{-----------------------------------------+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.++* A real `Table` is a table from the schema.++* `Subquery` derives a table from a `Query`.++* A joined table is a table derived from two other (real or derived) tables+according to the rules of the particular join type. `CrossJoin`, `InnerJoin`,+`LeftOuterJoin`, `RightOuterJoin` and `FullOuterJoin` are available and can+be nested using the `&` operator to match the left-to-right sequencing of+their placement in SQL.++ * @t1 & CrossJoin t2@. For every possible combination of rows from+ @t1@ and @t2@ (i.e., a Cartesian product), the joined table will contain+ a row consisting of all columns in @t1@ followed by all columns in @t2@.+ If the tables have @n@ and @m@ rows respectively, the joined table will+ have @n * m@ rows.++ * @t1 & InnerJoin t2 on@. For each row @r1@ of @t1@, the joined+ table has a row for each row in @t2@ that satisfies the @on@ condition+ with @r1@++ * @t1 & LeftOuterJoin t2 on@. First, an inner join is performed.+ Then, for each row in @t1@ that does not satisfy the @on@ condition with+ any row in @t2@, a joined row is added with null values in columns of @t2@.+ Thus, the joined table always has at least one row for each row in @t1@.++ * @t1 & RightOuterJoin t2 on@. First, an inner join is performed.+ Then, for each row in @t2@ that does not satisfy the @on@ condition with+ any row in @t1@, a joined row is added with null values in columns of @t1@.+ This is the converse of a left join: the result table will always+ have a row for each row in @t2@.++ * @t1 & FullOuterJoin t2 on@. First, an inner join is performed.+ Then, for each row in @t1@ that does not satisfy the @on@ condition with+ any row in @t2@, a joined row is added with null values in columns of @t2@.+ Also, for each row of @t2@ that does not satisfy the join condition+ with any row in @t1@, a joined row with null values in the columns of @t1@+ is added.+-}+data FromClause schema params tables where+ Table+ :: Aliased (Table schema) table+ -> FromClause schema params '[table]+ Subquery+ :: Aliased (Query schema params) table+ -> FromClause schema params '[table]+ CrossJoin+ :: FromClause schema params right+ -> FromClause schema params left+ -> FromClause schema params (Join left right)+ InnerJoin+ :: FromClause schema params right+ -> Condition (Join left right) 'Ungrouped params+ -> FromClause schema params left+ -> FromClause schema params (Join left right)+ LeftOuterJoin+ :: FromClause schema params right+ -> Condition (Join left right) 'Ungrouped params+ -> FromClause schema params left+ -> FromClause schema params (Join left (NullifyTables right))+ RightOuterJoin+ :: FromClause schema params right+ -> Condition (Join left right) 'Ungrouped params+ -> FromClause schema params left+ -> FromClause schema params (Join (NullifyTables left) right)+ FullOuterJoin+ :: FromClause schema params right+ -> Condition (Join left right) 'Ungrouped params+ -> FromClause schema params left+ -> FromClause schema params+ (Join (NullifyTables left) (NullifyTables right))++-- | Renders a `FromClause`.+renderFromClause :: FromClause schema params tables -> ByteString+renderFromClause = \case+ Table table -> renderAliased renderTable table+ Subquery selection -> renderAliased (parenthesized . renderQuery) selection+ CrossJoin right left ->+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right+ InnerJoin right on left -> renderJoin "INNER JOIN" right on left+ LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left+ RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left+ FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left+ where+ renderJoin op right on left =+ renderFromClause left <+> op <+> 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+ (tables :: TablesType)+ (by :: (Symbol,Symbol)) where+ By+ :: (HasUnique table tables columns, HasColumn column columns ty)+ => Alias column+ -> By tables '(table, column)+ By2+ :: (HasTable table tables columns, HasColumn column columns ty)+ => (Alias table, Alias column)+ -> By tables '(table, column)+deriving instance Show (By tables by)+deriving instance Eq (By tables by)+deriving instance Ord (By tables by)++-- | Renders a `By`.+renderBy :: By tables tabcolty -> ByteString+renderBy = \case+ By column -> renderAlias column+ By2 (table, column) -> renderAlias table <> "." <> 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@.+data GroupByClause tables grouping where+ NoGroups :: GroupByClause tables 'Ungrouped+ Group+ :: SListI bys+ => NP (By tables) bys+ -> GroupByClause tables ('Grouped bys)++-- | Renders a `GroupByClause`.+renderGroupByClause :: GroupByClause tables 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 tables grouping params where+ NoHaving :: HavingClause tables 'Ungrouped params+ Having+ :: [Condition tables ('Grouped bys) params]+ -> HavingClause tables ('Grouped bys) params+deriving instance Show (HavingClause tables grouping params)+deriving instance Eq (HavingClause tables grouping params)+deriving instance Ord (HavingClause tables grouping params)++-- | Render a `HavingClause`.+renderHavingClause :: HavingClause tables 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 tables grouping params where+ Asc+ :: Expression tables grouping params ('Required ('NotNull ty))+ -> SortExpression tables grouping params+ Desc+ :: Expression tables grouping params ('Required ('NotNull ty))+ -> SortExpression tables grouping params+ AscNullsFirst+ :: Expression tables grouping params ('Required ('Null ty))+ -> SortExpression tables grouping params+ AscNullsLast+ :: Expression tables grouping params ('Required ('Null ty))+ -> SortExpression tables grouping params+ DescNullsFirst+ :: Expression tables grouping params ('Required ('Null ty))+ -> SortExpression tables grouping params+ DescNullsLast+ :: Expression tables grouping params ('Required ('Null ty))+ -> SortExpression tables grouping params+deriving instance Show (SortExpression tables grouping params)++-- | Render a `SortExpression`.+renderSortExpression :: SortExpression tables 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"
+ src/Squeal/PostgreSQL/Schema.hs view
@@ -0,0 +1,324 @@+{-|+Module: Squeal.PostgreSQL.Schema+Description: Embedding of PostgreSQL type and alias system+Copyright: (c) Eitan Chatav, 2017+Maintainer: eitan@morphism.tech+Stability: experimental++Embedding of PostgreSQL type and alias system+-}++{-# LANGUAGE+ ConstraintKinds+ , DataKinds+ , DeriveAnyClass+ , DeriveDataTypeable+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , MagicHash+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , TypeInType+ , TypeOperators+#-}++module Squeal.PostgreSQL.Schema+ ( -- * Kinds+ PGType (..)+ , NullityType (..)+ , ColumnType (..)+ , ColumnsType+ , TablesType+ , Grouping (..)+ -- * Constraints+ , PGNum+ , PGIntegral+ , PGFloating+ -- * Aliases+ , (:::)+ , Alias (Alias)+ , renderAlias+ , Aliased (As)+ , renderAliased+ , IsLabel (..)+ , IsTableColumn (..)+ -- * Type Families+ , In+ , HasUnique+ , BaseType+ , SameTypes+ , AllNotNull+ , NotAllNull+ , NullifyType+ , NullifyColumns+ , NullifyTables+ , Join+ , Create+ , Drop+ , Alter+ , Rename+ -- * Generics+ , SameField+ , SameFields+ ) where++import Control.DeepSeq+import Data.ByteString+import Data.Monoid+import Data.String+import Generics.SOP (AllZip)+import GHC.Generics (Generic)+import GHC.Exts+import GHC.OverloadedLabels+import GHC.TypeLits++import qualified Generics.SOP.Type.Metadata as Type++-- | `PGType` is the promoted datakind of PostgreSQL types.+data PGType+ = PGbool -- ^ logical Boolean (true/false)+ | PGint2 -- ^ signed two-byte integer+ | PGint4 -- ^ signed four-byte integer+ | PGint8 -- ^ signed eight-byte integer+ | PGnumeric -- ^ arbitrary precision numeric type+ | PGfloat4 -- ^ single precision floating-point number (4 bytes)+ | PGfloat8 -- ^ double precision floating-point number (8 bytes)+ | PGchar Nat -- ^ fixed-length character string+ | PGvarchar Nat -- ^ variable-length character string+ | PGtext -- ^ variable-length character string+ | PGbytea -- ^ binary data ("byte array")+ | PGtimestamp -- ^ date and time (no time zone)+ | PGtimestamptz -- ^ date and time, including time zone+ | PGdate -- ^ calendar date (year, month, day)+ | PGtime -- ^ time of day (no time zone)+ | PGtimetz -- ^ time of day, including time zone+ | PGinterval -- ^ time span+ | PGuuid -- ^ universally unique identifier+ | PGinet -- ^ IPv4 or IPv6 host address+ | PGjson -- ^ textual JSON data+ | PGjsonb -- ^ binary JSON data, decomposed+ | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types++-- | `NullityType` encodes the potential presence or definite absence of a+-- @NULL@ allowing operations which are sensitive to such to be well typed.+data NullityType+ = Null PGType -- ^ @NULL@ may be present+ | NotNull PGType -- ^ @NULL@ is absent++-- | `ColumnType` encodes the allowance of @DEFAULT@ and the only way+-- to generate an `Optional` `Squeal.PostgreSQL.Expression.Expression`+-- is to use `Squeal.PostgreSQL.Expression.def`,+-- `Squeal.PostgreSQL.Expression.unDef` or+-- `Squeal.PostgreSQL.Expression.param`.+data ColumnType+ = Optional NullityType+ -- ^ @DEFAULT@ is allowed+ | Required NullityType+ -- ^ @DEFAULT@ is not allowed++-- | `ColumnsType` is a kind synonym for a row of `ColumnType`s.+type ColumnsType = [(Symbol,ColumnType)]++-- | `TablesType` is a kind synonym for a row of `ColumnsType`s.+-- It is used as a kind for both a schema, a disjoint union of tables,+-- and a joined table `Squeal.PostgreSQL.Query.FromClause`,+-- a product of tables.+type TablesType = [(Symbol,ColumnsType)]++-- | `Grouping` is an auxiliary namespace, created by+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used+-- for typesafe aggregation+data Grouping+ = Ungrouped+ | Grouped [(Symbol,Symbol)]++-- | `PGNum` is a constraint on `PGType` whose+-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.+type PGNum ty =+ In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]++-- | `PGFloating` is a constraint on `PGType` whose+-- `Squeal.PostgreSQL.Expression.Expression`s+-- have `Fractional` and `Floating` constraints.+type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]++-- | `PGIntegral` is a constraint on `PGType` whose+-- `Squeal.PostgreSQL.Expression.Expression`s+-- have `Squeal.PostgreSQL.Expression.div_` and+-- `Squeal.PostgreSQL.Expression.mod_` functions.+type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]++-- | `:::` is like a promoted version of `As`, a type level pair between+-- an alias and some type, usually a column alias and a `ColumnType` or+-- a table alias and a `ColumnsType`.+type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)++-- | `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,Generic,Ord,Show,NFData)+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where+ fromLabel = Alias++-- | >>> renderAlias #alias+-- "alias"+renderAlias :: KnownSymbol alias => Alias alias -> ByteString+renderAlias = fromString . symbolVal++-- | 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))++-- | >>> 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 " <> renderAlias alias++-- | Analagous to `IsLabel`, the constraint+-- `IsTableColumn` defines `!` for a column alias qualified+-- by a table alias.+class IsTableColumn table column expression where+ (!) :: Alias table -> Alias column -> expression+ infixl 9 !+instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)++-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.+type family In x xs :: Constraint where+ In x (x ': xs) = ()+ In x (y ': xs) = In x xs++-- | @HasUnique alias xs x@ is a constraint that proves that @xs@ is a singleton+-- of @alias ::: x@.+type HasUnique alias xs x = xs ~ '[alias ::: x]++-- | `BaseType` forgets about @NULL@ and @DEFAULT@+type family BaseType (ty :: ColumnType) :: PGType where+ BaseType (optionality (nullity pg)) = pg++-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same+-- length and the same `ColumnType`s.+type family SameTypes+ (columns0 :: ColumnsType) (columns1 :: ColumnsType)+ :: Constraint where+ SameTypes '[] '[] = ()+ SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)+ = (ty0 ~ ty1, SameTypes columns0 columns1)++-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.+type family AllNotNull (columns :: ColumnsType) :: Constraint where+ AllNotNull '[] = ()+ AllNotNull ((column ::: (optionality ('NotNull ty))) ': columns)+ = AllNotNull columns++-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some+-- @NOT NULL@.+type family NotAllNull columns :: Constraint where+ NotAllNull ((column ::: (optionality ('NotNull ty))) ': columns) = ()+ NotAllNull ((column ::: (optionality ('Null ty))) ': columns)+ = NotAllNull columns++-- | `NullifyType` is an idempotent that nullifies a `ColumnType`.+type family NullifyType (ty :: ColumnType) :: ColumnType where+ NullifyType (optionality ('Null ty)) = optionality ('Null ty)+ NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)++-- | `NullifyColumns` is an idempotent that nullifies a `ColumnsType`.+type family NullifyColumns (columns :: ColumnsType) :: ColumnsType where+ NullifyColumns '[] = '[]+ NullifyColumns ((column ::: ty) ': columns) =+ (column ::: NullifyType ty) ': NullifyColumns columns++-- | `NullifyTables` is an idempotent that nullifies a `TablesType`+-- used to nullify the left or right hand side of an outer join+-- in a `Squeal.PostgreSQL.Query.FromClause`.+type family NullifyTables (tables :: TablesType) :: TablesType where+ NullifyTables '[] = '[]+ NullifyTables ((table ::: columns) ': tables) =+ (table ::: NullifyColumns columns) ': NullifyTables 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.addColumnDefault` and+-- `Squeal.PostgreSQL.Definition.addColumnNull` statements.+type family Create alias x xs where+ Create alias x '[] = '[alias ::: x]+ Create alias y (x ': xs) = x ': Create alias y xs++-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@+-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements+-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.+type family Drop alias xs where+ Drop alias ((alias ::: x) ': xs) = xs+ Drop alias (x ': xs) = x ': Drop alias xs++-- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@+-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`+-- and `Squeal.PostgreSQL.Definition.alterColumn`.+type family Alter alias xs x where+ Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs+ Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1++-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@+-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and+-- `Squeal.PostgreSQL.Definition.renameColumn`.+type family Rename alias0 alias1 xs where+ Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs+ Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs++-- | A `SameField` constraint is an equality constraint on a+-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.+class SameField+ (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,ColumnType)) where+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)++-- | A `SameFields` constraint proves that a+-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same+-- field names as the column aliases of a `ColumnsType`.+type family SameFields+ (datatypeInfo :: Type.DatatypeInfo) (columns :: ColumnsType)+ :: Constraint where+ SameFields+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])+ columns+ = AllZip SameField fields columns+ SameFields+ ('Type.Newtype _module _datatype ('Type.Record _constructor fields))+ columns+ = AllZip SameField fields columns
+ test/DocTest.hs view
@@ -0,0 +1,14 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest+ [ "-isrc"+ , "src/Squeal/PostgreSQL/Binary.hs"+ , "src/Squeal/PostgreSQL/Definition.hs"+ , "src/Squeal/PostgreSQL/Manipulation.hs"+ , "src/Squeal/PostgreSQL/Query.hs"+ , "src/Squeal/PostgreSQL/Expression.hs"+ , "src/Squeal/PostgreSQL/PQ.hs"+ ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Squeal/PostgreSQL/DefinitionSpec.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE+ DataKinds+ , MagicHash+ , OverloadedLabels+ , OverloadedStrings+ , TypeApplications+ , TypeOperators+#-}++module Squeal.PostgreSQL.DefinitionSpec where++import Control.Category ((>>>))+import Data.Function+import Generics.SOP hiding (from)+import Test.Hspec++import Squeal.PostgreSQL++spec :: Spec+spec = do+ let+ definition `definitionRenders` str =+ renderDefinition definition `shouldBe` str+ it "should render CREATE TABLE statements" $ do+ createTable #table1+ ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)+ [primaryKey (Column #col1 :* Column #col2 :* Nil)]+ `definitionRenders`+ "CREATE TABLE table1\+ \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\+ \ PRIMARY KEY (col1, col2));"+ createTable #table2+ ( serial `As` #col1 :*+ text `As` #col2 :*+ (int8 & notNull & default_ 8) `As` #col3 :* Nil )+ [check (#col3 .> 0)]+ `definitionRenders`+ "CREATE TABLE table2\+ \ (col1 serial,\+ \ col2 text,\+ \ col3 int8 NOT NULL DEFAULT 8,\+ \ CHECK ((col3 > 0)));"+ let+ statement :: Definition '[]+ '[ "users" :::+ '[ "id" ::: 'Optional ('NotNull 'PGint4)+ , "username" ::: 'Required ('NotNull 'PGtext)+ ]+ , "emails" :::+ '[ "id" ::: 'Optional ('NotNull 'PGint4)+ , "userid" ::: 'Required ('NotNull 'PGint4)+ , "email" ::: 'Required ('NotNull 'PGtext)+ ]+ ]+ statement =+ createTable #users+ (serial `As` #id :* (text & notNull) `As` #username :* Nil)+ [primaryKey (Column #id :* Nil)]+ >>>+ createTable #emails+ ( serial `As` #id :*+ (integer & notNull) `As` #userid :*+ (text & notNull) `As` #email :* Nil )+ [ primaryKey (Column #id :* Nil)+ , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)+ OnDeleteCascade OnUpdateRestrict+ , unique (Column #email :* Nil)+ , check (#email ./= "")+ ]+ statement `definitionRenders`+ "CREATE TABLE users\+ \ (id serial, username text NOT NULL,\+ \ PRIMARY KEY (id));\+ \ \+ \CREATE TABLE emails\+ \ (id serial,\+ \ userid integer NOT NULL,\+ \ email text NOT NULL,\+ \ PRIMARY KEY (id),\+ \ FOREIGN KEY (userid) REFERENCES users (id)\+ \ ON DELETE CASCADE ON UPDATE RESTRICT,\+ \ UNIQUE (email),\+ \ CHECK ((email <> E'')));"+ it "should render DROP TABLE statements" $ do+ let+ statement :: Definition Tables '[]+ statement = dropTable #table1+ statement `definitionRenders` "DROP TABLE table1;"++type Columns =+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4)+ ]+type Tables = '[ "table1" ::: Columns ]+type SumAndCol1 =+ '[ "sum" ::: 'Required ('NotNull 'PGint4)+ , "col1" ::: 'Required ('NotNull 'PGint4)+ ]+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]+type StudentsTable = '["students" ::: StudentsColumns]+type OrderColumns =+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)+ , "orderVal" ::: 'Required ('NotNull 'PGtext)+ , "customerID" ::: 'Required ('NotNull 'PGint4)+ , "shipperID" ::: 'Required ('NotNull 'PGint4)+ ]+type CustomerColumns =+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)+ ]+type ShipperColumns =+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)+ ]+type JoinTables =+ '[ "orders" ::: OrderColumns+ , "customers" ::: CustomerColumns+ , "shippers" ::: ShipperColumns+ ]+type ValueColumns =+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)+ ]
+ test/Squeal/PostgreSQL/ManipulationSpec.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE+ DataKinds+ , MagicHash+ , OverloadedLabels+ , OverloadedStrings+ , TypeApplications+ , TypeOperators+#-}++module Squeal.PostgreSQL.ManipulationSpec where++import Generics.SOP hiding (from)+import Test.Hspec++import Squeal.PostgreSQL++spec :: Spec+spec = do+ let+ manipulation `manipulationRenders` str =+ renderManipulation manipulation `shouldBe` str+ it "correctly renders returning INSERTs" $ do+ let+ statement :: Manipulation Tables '[] SumAndCol1+ statement =+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])+ OnConflictDoRaise+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ statement `manipulationRenders`+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"+ it "correctly renders simple UPDATEs" $ do+ let+ statement :: Manipulation Tables '[] '[]+ statement =+ update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+ (#col1 ./= #col2) (Returning Nil)+ statement `manipulationRenders`+ "UPDATE table1 SET col1 = 2\+ \ WHERE (col1 <> col2);"+ it "correctly renders returning UPDATEs" $ do+ let+ statement :: Manipulation Tables '[] SumAndCol1+ statement =+ update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+ (#col1 ./= #col2)+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ statement `manipulationRenders`+ "UPDATE table1 SET col1 = 2\+ \ WHERE (col1 <> col2)\+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"+ it "correctly renders upsert INSERTs" $ do+ let+ statement :: Manipulation Tables '[] '[]+ statement =+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])+ (OnConflictDoUpdate+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)+ (Returning Nil)+ statement `manipulationRenders`+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\+ \ ON CONFLICT DO UPDATE\+ \ SET col1 = 2;"+ it "correctly renders returning upsert INSERTs" $ do+ let+ statement :: Manipulation Tables '[] SumAndCol1+ statement =+ insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])+ (OnConflictDoUpdate+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)+ (Just (#col1 ./= #col2)))+ (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ statement `manipulationRenders`+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\+ \ ON CONFLICT DO UPDATE\+ \ SET col1 = 2\+ \ WHERE (col1 <> col2)\+ \ RETURNING (col1 + col2) AS sum, col1 AS col1;"+ it "correctly renders DELETEs" $ do+ let+ statement :: Manipulation Tables '[] '[]+ statement = deleteFrom #table1 (#col1 .== #col2) (Returning Nil)+ statement `manipulationRenders`+ "DELETE FROM table1 WHERE (col1 = col2);"+ it "should be safe against SQL injection in literal text" $ do+ let+ statement :: Manipulation StudentsTable '[] '[]+ statement = insertInto #students+ (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])+ OnConflictDoRaise (Returning Nil)+ statement `manipulationRenders`+ "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"++type Columns =+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4)+ ]+type Tables = '[ "table1" ::: Columns ]+type SumAndCol1 =+ '[ "sum" ::: 'Required ('NotNull 'PGint4)+ , "col1" ::: 'Required ('NotNull 'PGint4)+ ]+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]+type StudentsTable = '["students" ::: StudentsColumns]+type OrderColumns =+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)+ , "orderVal" ::: 'Required ('NotNull 'PGtext)+ , "customerID" ::: 'Required ('NotNull 'PGint4)+ , "shipperID" ::: 'Required ('NotNull 'PGint4)+ ]+type CustomerColumns =+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)+ ]+type ShipperColumns =+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)+ ]+type JoinTables =+ '[ "orders" ::: OrderColumns+ , "customers" ::: CustomerColumns+ , "shippers" ::: ShipperColumns+ ]+type ValueColumns =+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)+ ]
+ test/Squeal/PostgreSQL/QuerySpec.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE+ DataKinds+ , MagicHash+ , OverloadedLabels+ , OverloadedStrings+ , TypeApplications+ , TypeOperators+#-}++module Squeal.PostgreSQL.QuerySpec where++import Data.Function+import Generics.SOP hiding (from)+import Test.Hspec++import Squeal.PostgreSQL++spec :: Spec+spec = do+ let+ qry `queryRenders` str =+ renderManipulation (queryStatement qry) `shouldBe` str+ it "correctly renders a simple SELECT query" $ do+ let+ statement :: Query Tables '[] SumAndCol1+ statement =+ select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ (from (Table (#table1 `As` #table1)) & where_ (#col1 .> #col2))+ statement `queryRenders`+ "SELECT (col1 + col2) AS sum, col1 AS col1\+ \ FROM table1 AS table1 WHERE (col1 > col2);"+ it "combines WHEREs using AND" $ do+ let+ statement :: Query Tables '[] SumAndCol1+ statement =+ select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ (from (Table (#table1 `As` #table1)) & where_ true & where_ false)+ statement `queryRenders`+ "SELECT (col1 + col2) AS sum, col1 AS col1\+ \ FROM table1 AS table1 WHERE (TRUE AND FALSE);"+ it "performs sub SELECTs" $ do+ let+ statement :: Query Tables '[] SumAndCol1+ statement =+ selectStar (from (Subquery+ (select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)+ (from (Table (#table1 `As` #table1))) `As` #sub)))+ statement `queryRenders`+ "SELECT * FROM\+ \ (SELECT (col1 + col2) AS sum, col1 AS col1\+ \ FROM table1 AS table1) AS sub;"+ it "does LIMIT clauses" $ do+ let+ statement :: Query Tables '[] Columns+ statement = selectStar (from (Table (#table1 `As` #table1)) & limit 1)+ statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"+ it "should use the minimum of given LIMITs" $ do+ let+ statement :: Query Tables '[] Columns+ statement =+ selectStar (from (Table (#table1 `As` #table1)) & limit 1 & limit 2)+ statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"+ it "should render parameters using $ signs" $ do+ let+ statement :: Query Tables '[ 'Required ('NotNull 'PGbool)] Columns+ statement = selectStar+ (from (Table (#table1 `As` #table1)) & where_ (param @1))+ statement `queryRenders`+ "SELECT * FROM table1 AS table1 WHERE ($1 :: bool);"+ it "does OFFSET clauses" $ do+ let+ statement :: Query Tables '[] Columns+ statement =+ selectStar (from (Table (#table1 `As` #table1)) & offset 1)+ statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 1;"+ it "should use the sum of given OFFSETs" $ do+ let+ statement :: Query Tables '[] Columns+ statement = selectStar+ (from (Table (#table1 `As` #table1)) & offset 1 & offset 2)+ statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 3;"+ it "should render GROUP BY and HAVING clauses" $ do+ let+ statement :: Query Tables '[] SumAndCol1+ statement =+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)+ ( from (Table (#table1 `As` #table1))+ & group (By #col1 :* Nil) + & having (#col1 + sum_ #col2 .> 1) )+ statement `queryRenders`+ "SELECT sum(col2) AS sum, col1 AS col1\+ \ FROM table1 AS table1\+ \ GROUP BY col1\+ \ HAVING ((col1 + sum(col2)) > 1);"+ describe "JOINs" $ do+ it "should render CROSS JOINs" $ do+ let+ statement :: Query JoinTables '[] ValueColumns+ statement = select+ ( #orders ! #orderVal `As` #orderVal :*+ #customers ! #customerVal `As` #customerVal :*+ #shippers ! #shipperVal `As` #shipperVal :* Nil )+ ( from (Table (#orders `As` #orders)+ & CrossJoin (Table (#customers `As` #customers))+ & CrossJoin (Table (#shippers `As` #shippers))) )+ statement `queryRenders`+ "SELECT\+ \ orders.orderVal AS orderVal,\+ \ customers.customerVal AS customerVal,\+ \ shippers.shipperVal AS shipperVal\+ \ FROM orders AS orders\+ \ CROSS JOIN customers AS customers\+ \ CROSS JOIN shippers AS shippers;"+ it "should render INNER JOINs" $ do+ let+ statement :: Query JoinTables '[] ValueColumns+ statement = select+ ( (#orders ! #orderVal) `As` #orderVal+ :* (#customers ! #customerVal) `As` #customerVal+ :* (#shippers ! #shipperVal) `As` #shipperVal :* Nil)+ ( from (Table (#orders `As` #orders)+ & InnerJoin (Table (#customers `As` #customers))+ ((#orders ! #customerID) .== (#customers ! #customerID))+ & InnerJoin (Table (#shippers `As` #shippers))+ ((#orders ! #shipperID) .== (#shippers ! #shipperID))))+ statement `queryRenders`+ "SELECT\+ \ orders.orderVal AS orderVal,\+ \ customers.customerVal AS customerVal,\+ \ shippers.shipperVal AS shipperVal\+ \ FROM orders AS orders\+ \ INNER JOIN customers AS customers\+ \ ON (orders.customerID = customers.customerID)\+ \ INNER JOIN shippers AS shippers\+ \ ON (orders.shipperID = shippers.shipperID);"+ it "should render self JOINs" $ do+ let+ statement :: Query JoinTables '[] OrderColumns+ statement = selectDotStar #orders1+ (from (Table (#orders `As` #orders1)+ & CrossJoin (Table (#orders `As` #orders2))))+ statement `queryRenders`+ "SELECT orders1.*\+ \ FROM orders AS orders1\+ \ CROSS JOIN orders AS orders2;"++type Columns =+ '[ "col1" ::: 'Required ('NotNull 'PGint4)+ , "col2" ::: 'Required ('NotNull 'PGint4)+ ]+type Tables = '[ "table1" ::: Columns ]+type SumAndCol1 =+ '[ "sum" ::: 'Required ('NotNull 'PGint4)+ , "col1" ::: 'Required ('NotNull 'PGint4)+ ]+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]+type StudentsTable = '["students" ::: StudentsColumns]+type OrderColumns =+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)+ , "orderVal" ::: 'Required ('NotNull 'PGtext)+ , "customerID" ::: 'Required ('NotNull 'PGint4)+ , "shipperID" ::: 'Required ('NotNull 'PGint4)+ ]+type CustomerColumns =+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)+ ]+type ShipperColumns =+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)+ ]+type JoinTables =+ '[ "orders" ::: OrderColumns+ , "customers" ::: CustomerColumns+ , "shippers" ::: ShipperColumns+ ]+type ValueColumns =+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)+ ]