squeal-postgresql 0.5.2.0 → 0.9.2.0
raw patch · 90 files changed
Files
- README.md +2/−2
- bench/Gauge.hs +116/−0
- bench/Gauge/DBHelpers.hs +67/−0
- bench/Gauge/DBSetup.hs +134/−0
- bench/Gauge/Queries.hs +145/−0
- bench/Gauge/Schema.hs +93/−0
- exe/Example.hs +193/−31
- squeal-postgresql.cabal +146/−57
- src/Squeal/PostgreSQL.hs +84/−43
- src/Squeal/PostgreSQL/Alias.hs +0/−249
- src/Squeal/PostgreSQL/Binary.hs +0/−757
- src/Squeal/PostgreSQL/Definition.hs +86/−1108
- src/Squeal/PostgreSQL/Definition/Comment.hs +166/−0
- src/Squeal/PostgreSQL/Definition/Constraint.hs +352/−0
- src/Squeal/PostgreSQL/Definition/Function.hs +250/−0
- src/Squeal/PostgreSQL/Definition/Index.hs +187/−0
- src/Squeal/PostgreSQL/Definition/Procedure.hs +172/−0
- src/Squeal/PostgreSQL/Definition/Schema.hs +114/−0
- src/Squeal/PostgreSQL/Definition/Table.hs +537/−0
- src/Squeal/PostgreSQL/Definition/Type.hs +292/−0
- src/Squeal/PostgreSQL/Definition/View.hs +180/−0
- src/Squeal/PostgreSQL/Expression.hs +365/−118
- src/Squeal/PostgreSQL/Expression/Aggregate.hs +356/−174
- src/Squeal/PostgreSQL/Expression/Array.hs +291/−0
- src/Squeal/PostgreSQL/Expression/Collection.hs +0/−169
- src/Squeal/PostgreSQL/Expression/Comparison.hs +30/−25
- src/Squeal/PostgreSQL/Expression/Composite.hs +95/−0
- src/Squeal/PostgreSQL/Expression/Default.hs +60/−0
- src/Squeal/PostgreSQL/Expression/Inline.hs +363/−0
- src/Squeal/PostgreSQL/Expression/Json.hs +99/−84
- src/Squeal/PostgreSQL/Expression/Literal.hs +0/−87
- src/Squeal/PostgreSQL/Expression/Logic.hs +23/−20
- src/Squeal/PostgreSQL/Expression/Math.hs +18/−19
- src/Squeal/PostgreSQL/Expression/Null.hs +59/−22
- src/Squeal/PostgreSQL/Expression/Parameter.hs +79/−26
- src/Squeal/PostgreSQL/Expression/Range.hs +227/−0
- src/Squeal/PostgreSQL/Expression/SetOf.hs +0/−106
- src/Squeal/PostgreSQL/Expression/Sort.hs +39/−23
- src/Squeal/PostgreSQL/Expression/Subquery.hs +25/−21
- src/Squeal/PostgreSQL/Expression/Text.hs +36/−12
- src/Squeal/PostgreSQL/Expression/TextSearch.hs +27/−26
- src/Squeal/PostgreSQL/Expression/Time.hs +77/−27
- src/Squeal/PostgreSQL/Expression/Type.hs +319/−91
- src/Squeal/PostgreSQL/Expression/Window.hs +158/−94
- src/Squeal/PostgreSQL/List.hs +0/−141
- src/Squeal/PostgreSQL/Manipulation.hs +178/−403
- src/Squeal/PostgreSQL/Manipulation/Call.hs +118/−0
- src/Squeal/PostgreSQL/Manipulation/Delete.hs +106/−0
- src/Squeal/PostgreSQL/Manipulation/Insert.hs +289/−0
- src/Squeal/PostgreSQL/Manipulation/Update.hs +135/−0
- src/Squeal/PostgreSQL/Migration.hs +0/−446
- src/Squeal/PostgreSQL/PG.hs +0/−365
- src/Squeal/PostgreSQL/PQ.hs +0/−688
- src/Squeal/PostgreSQL/Pool.hs +0/−122
- src/Squeal/PostgreSQL/Query.hs +157/−785
- src/Squeal/PostgreSQL/Query/From.hs +115/−0
- src/Squeal/PostgreSQL/Query/From/Join.hs +295/−0
- src/Squeal/PostgreSQL/Query/From/Set.hs +205/−0
- src/Squeal/PostgreSQL/Query/Select.hs +253/−0
- src/Squeal/PostgreSQL/Query/Table.hs +410/−0
- src/Squeal/PostgreSQL/Query/Values.hs +89/−0
- src/Squeal/PostgreSQL/Query/With.hs +246/−0
- src/Squeal/PostgreSQL/Render.hs +15/−5
- src/Squeal/PostgreSQL/Schema.hs +0/−449
- src/Squeal/PostgreSQL/Session.hs +333/−0
- src/Squeal/PostgreSQL/Session/Connection.hs +78/−0
- src/Squeal/PostgreSQL/Session/Decode.hs +698/−0
- src/Squeal/PostgreSQL/Session/Encode.hs +681/−0
- src/Squeal/PostgreSQL/Session/Exception.hs +100/−0
- src/Squeal/PostgreSQL/Session/Indexed.hs +126/−0
- src/Squeal/PostgreSQL/Session/Migration.hs +456/−0
- src/Squeal/PostgreSQL/Session/Monad.hs +765/−0
- src/Squeal/PostgreSQL/Session/Oid.hs +234/−0
- src/Squeal/PostgreSQL/Session/Pool.hs +138/−0
- src/Squeal/PostgreSQL/Session/Result.hs +223/−0
- src/Squeal/PostgreSQL/Session/Statement.hs +220/−0
- src/Squeal/PostgreSQL/Session/Transaction.hs +156/−0
- src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs +300/−0
- src/Squeal/PostgreSQL/Transaction.hs +0/−252
- src/Squeal/PostgreSQL/Type.hs +202/−0
- src/Squeal/PostgreSQL/Type/Alias.hs +349/−0
- src/Squeal/PostgreSQL/Type/List.hs +204/−0
- src/Squeal/PostgreSQL/Type/PG.hs +346/−0
- src/Squeal/PostgreSQL/Type/Schema.hs +842/−0
- test/Doc.hs +6/−0
- test/DocTest.hs +0/−18
- test/Property.hs +316/−0
- test/Spec.hs +251/−0
- test/Specs/ExceptionHandling.hs +0/−140
- test/Specs/Specs.hs +0/−7
README.md view
@@ -1,8 +1,8 @@ # squeal-postgresql -+ -[](https://circleci.com/gh/morphismtech/squeal)+[](https://github.com/morphismtech/squeal/actions/workflows/ci.yml) [Github](https://github.com/morphismtech/squeal)
+ bench/Gauge.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Squeal.PostgreSQL hiding ( defaultMain )+import Gauge.Main+import Gauge.Main.Options ( defaultConfig+ , Config(..)+ , Verbosity(..)+ , DisplayMode(..)+ , Mode(..)+ )+import GHC.Generics+import qualified Generics.SOP as SOP+import Test.QuickCheck+-- For CI+import Main.Utf8 ( withUtf8 )+-- For keeping a track of which question ID to query+import Data.Int ( Int64 )+import Data.IORef+-- Project imports+import Gauge.Schema+import Gauge.Queries+import Gauge.DBSetup ( teardownDB )+import Gauge.DBHelpers ( initDBWithPool+ , getRandomUser+ , runDbWithPool+ , SquealPool+ )++main :: IO ()+main = do+ -- A mutable hack here to keep track of+ -- pulling a new user by ID from the db instead of the same id+ currentId <- newIORef (1 :: UserId)++ -- Define benchmarks+ let+ queryRenderGroup :: Benchmark+ queryRenderGroup = bgroup+ "Render Queries"+ [ bench "createUser: weak head normal form" $ whnf renderSQL createUser+ , bench "createUser: normal form" $ nf renderSQL createUser+ , bench "userDetails: weak head normal form" $ whnf renderSQL userDetails+ , bench "userDetails: normal form" $ nf renderSQL userDetails+ , bench "insertDeviceDetails: weak head normal form"+ $ whnf renderSQL insertDeviceDetails+ , bench "insertDeviceDetails: normal form"+ $ nf renderSQL insertDeviceDetails+ ]++ -- Queries against an actual DB++ -- 1. Initialize Schema to DB+ -- 2. Make connection pool and pass it to tests+ -- 3. Generate users on the fly and add them to DB+ -- 4. Tear the Schema down from the DB++ dbInsertsGroup :: Benchmark+ dbInsertsGroup =+ envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup+ "Run individual INSERTs against DB using a connection pool"+ [ bgroup+ "INSERT: add users to the table users"+ [ bench "Run individual INSERT statement" $ makeRunOnce $ perRunEnv+ getRandomUser+ -- The actual action to benchmark+ (\(user :: InsertUser) ->+ runDbWithPool pool $ createUserSession user+ )+ ]+ ]++ dbSelectsGroup :: Benchmark+ dbSelectsGroup =+ envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup+ "Run individual SELECTs against DB using a connection pool"+ [ bgroup+ "SELECT: fetch users from the table users individually"+ [ bench "Fetch a single user" $ makeRunOnce $ perRunEnv+ (insertAndIncrement pool currentId)+ (\(id_ :: UserId) -> runDbWithPool pool $ userDetailsSession id_+ )+ ]+ ]++ withUtf8 $ defaultMain [queryRenderGroup, dbInsertsGroup, dbSelectsGroup]+++-- | Configure the benchmark to run only once (per IO action)+makeRunOnce :: Benchmarkable -> Benchmarkable+makeRunOnce current = current { perRun = True }++getAndIncrementId :: (IORef UserId) -> IO UserId+getAndIncrementId currentId = do+ current <- readIORef currentId+ writeIORef currentId (current + 1)+ return current++-- | This INSERTs a row in the db so that there's always a row to query.+-- Otherwise 'getRow 0' throws an exception.+-- NOTE: will make benchmark time slower but does not affect results.+insertAndIncrement :: SquealPool -> (IORef UserId) -> IO UserId+insertAndIncrement pool currentId = do+ user <- getRandomUser+ _ <- runDbWithPool pool $ createUserSession user+ getAndIncrementId currentId
+ bench/Gauge/DBHelpers.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Gauge.DBHelpers where++import qualified Data.ByteString.Char8 as C+import qualified Data.Text as T+import Control.Monad ( void )+import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Loops ( iterateWhile )+import GHC.Generics ( Generic )+import Test.QuickCheck+import Squeal.PostgreSQL+import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe+import Control.DeepSeq+-- Project imports+import Gauge.Schema ( Schemas )+import Gauge.Queries ( InsertUser(..) )+import Gauge.DBSetup++newtype SquealPool = SquealPool {getSquealPool :: Pool (K Connection Schemas)} deriving (Generic)+-- Below may be wrong - it may screw up the whole connection pool using in tests+instance NFData SquealPool where+ rnf = rwhnf++runDbErr+ :: SquealPool -> PQ Schemas Schemas IO b -> IO (Either SquealException b)+runDbErr pool session = do+ liftIO . runUsingConnPool pool $ trySqueal (Unsafe.transactionally_ session)++runDbWithPool :: SquealPool -> PQ Schemas Schemas IO b -> IO b+runDbWithPool pool session = do+ errOrResult <- runDbErr pool session+ case errOrResult of+ Left err -> throwSqueal err+ Right result -> return result++-- | Helper+runUsingConnPool :: SquealPool -> PQ Schemas Schemas IO x -> IO x+runUsingConnPool (SquealPool pool) = usingConnectionPool pool++makePool :: C.ByteString -> IO SquealPool+makePool connStr = do+ pool <- createConnectionPool connStr 1 0.5 10+ return $ SquealPool pool++initDBWithPool :: IO SquealPool+initDBWithPool = do+ void initDB+ pool <- makePool connectionString+ return pool++getRandomUser :: IO InsertUser+getRandomUser = iterateWhile noEmptyEmail $ generate arbitrary+ where+ noEmptyEmail InsertUser { userEmail = userEmail } = T.length userEmail < 5
+ bench/Gauge/DBSetup.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Gauge.DBSetup where++import Data.ByteString ( ByteString )+import qualified Data.ByteString.Char8 as C+import Control.Monad ( void )+import GHC.Generics+import Squeal.PostgreSQL+-- Project imports+import Gauge.Schema ( Schemas+ , DeviceOS+ , IPLocation+ )+++-- First create enums as they're needed in the Schema+setup :: Definition (Public '[]) Schemas+setup =+ createTypeEnumFrom @DeviceOS #device_os+ >>> createTypeCompositeFrom @IPLocation #ip_location+ >>> createTable+ #users+ ( serial8+ `as` #id+ :* (text & notNullable)+ `as` #email+ :* (text & notNullable)+ `as` #password+ :* (text & nullable)+ `as` #first_name+ :* (int2 & nullable)+ `as` #birthyear+ )+ (primaryKey #id `as` #pk_users :* unique #email `as` #email)+ >>> createTable+ #user_devices+ ( serial8+ `as` #id+ :* notNullable int8+ `as` #user_id+ :* (text & notNullable)+ `as` #token+ :* (typedef #device_os & notNullable)+ `as` #os+ )+ ( primaryKey #id+ `as` #pk_user_devices+ :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade)+ `as` #fk_user_id+ :* unique #token+ `as` #token+ )++-- Drop types last because tables depend on them+teardown :: Definition Schemas (Public '[])+teardown =+ dropTableCascade #user_devices+ >>> dropTableCascade #users+ >>> dropType #ip_location+ >>> dropType #device_os++-- With env vars, we could use the commented keys+data PGConfig = PGConfig+ { pgHost :: String -- "PG_HOST"+ , pgPort :: Int -- "PG_PORT"+ , pgDbname :: String -- "PG_DBNAME" + , pgUser :: String -- "PG_USER"+ , pgPassword :: String -- "PG_PASSWORD" + }+ deriving (Generic, Show)++-- | Helper: unused now, but primarily for testing locally+makeConnStr :: PGConfig -> ByteString+makeConnStr PGConfig { pgHost = host, pgPort = portNumber, pgDbname = dbName, pgUser = user, pgPassword = pw }+ = C.pack+ $ "host="+ <> host+ <> " dbname="+ <> dbName+ <> " user="+ <> user+ <> " password="+ <> pw+ <> " port="+ <> show portNumber++connectionString :: ByteString+connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"++performDBAction :: Definition a b -> String -> IO ()+performDBAction action message = do+ void+ $ withConnection connectionString+ $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;")+ & pqThen (define action)+ putStrLn message++initDB :: IO ()+initDB =+ performDBAction setup "Initialized Schema & corresponding tables for Database"++teardownDB :: IO ()+teardownDB = performDBAction teardown "Dropped all database tables"++dbSchema :: Definition '["public" ::: '[]] (Drop "public" '["public" ::: '[]])+dbSchema = dropSchemaCascade #public++dropDBSchema :: IO ()+dropDBSchema = performDBAction dbSchema "Dropped Public schema from database"++-- | Concatenate two `ByteString`s with a space between.+(<+>) :: ByteString -> ByteString -> ByteString+infixr 7 <+>+str1 <+> str2 = str1 <> " " <> str2++-- | Drop table custom SQL statement with 'cascade'+dropTableCascade+ :: (Has sch schemas schema, Has tab schema ( 'Table table))+ => QualifiedAlias sch tab -- ^ table to remove+ -> Definition schemas (Alter sch (Drop tab schema) schemas)+dropTableCascade tab =+ UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> " cascade;"
+ bench/Gauge/Queries.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}++module Gauge.Queries where++import Squeal.PostgreSQL+import GHC.Generics ( Generic )+import qualified Generics.SOP as SOP+-- Need below for deriving instances+import Control.DeepSeq+import Data.Text ( Text )+import Data.Int ( Int16+ , Int64+ )+import Test.QuickCheck ( Arbitrary(..) )+import Generic.Random ( genericArbitrarySingle )+-- Import Orphan instances+import Test.QuickCheck.Instances ( )+-- Project imports+import Gauge.Schema++-- Types++type UserId = Int64+-- Insert user+data InsertUser = InsertUser+ { userEmail :: Text+ , userPassword :: Text+ , userFirstName :: Maybe Text+ , userBirthyear :: Maybe Int16+ }+ deriving (Show, Eq, Generic, NFData)+instance SOP.Generic InsertUser+instance SOP.HasDatatypeInfo InsertUser+-- Arbitrary instances for producing values with quickcheck+instance Arbitrary InsertUser where+ arbitrary = genericArbitrarySingle++sampleInsertUser :: InsertUser+sampleInsertUser = InsertUser { userEmail = "mark@gmail.com"+ , userPassword = "MySecretPassword"+ , userFirstName = Just "Mark"+ , userBirthyear = Just 1980+ }++data APIDBUser_ = APIDBUser_+ { userId :: UserId+ , email :: Text+ , first_name :: Maybe Text+ , birthyear :: Maybe Int16+ }+ deriving (Show, Eq, Generic, NFData)+instance SOP.Generic APIDBUser_+instance SOP.HasDatatypeInfo APIDBUser_+-- Arbitrary instances for producing values with quickcheck+instance Arbitrary APIDBUser_ where+ arbitrary = genericArbitrarySingle++data Row3 a b c = Row4+ { col1 :: a+ , col2 :: b+ , col3 :: c+ }+ deriving stock Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)++-- (UserId, Token, OS)+type DeviceDetailsRow = Row3 UserId Text (Enumerated DeviceOS)++-- -- Queries++createUserSession :: InsertUser -> PQ Schemas Schemas IO APIDBUser_+createUserSession insertUser =+ getRow 0 =<< manipulateParams createUser insertUser++createUser :: Manipulation_ Schemas InsertUser APIDBUser_+createUser = insertInto+ #users+ (Values_+ ( Default+ `as` #id+ :* Set (param @1)+ `as` #email+ :* Set (param @2)+ `as` #password+ :* Set (param @3)+ `as` #first_name+ :* Set (param @4 & cast int2)+ `as` #birthyear+ )+ )+ OnConflictDoRaise+ (Returning_+ ( #id+ `as` #userId+ :* #email+ `as` #email+ :* #first_name+ `as` #first_name+ :* #birthyear+ `as` #birthyear+ )+ )++userDetailsSession :: UserId -> PQ Schemas Schemas IO APIDBUser_+userDetailsSession uID = getRow 0 =<< runQueryParams userDetails (Only uID)++userDetails :: Query_ Schemas (Only UserId) APIDBUser_+userDetails = select_+ ( #id+ `as` #userId+ :* #email+ `as` #email+ :* #first_name+ `as` #first_name+ :* #birthyear+ `as` #birthyear+ )+ (from (table #users) & where_ (#id .== (param @1 & cast int8)))++insertDeviceDetails :: Manipulation_ Schemas DeviceDetailsRow ()+insertDeviceDetails = insertInto+ #user_devices+ (Values_+ ( Default+ `as` #id+ :* Set (param @1)+ `as` #user_id+ :* Set (param @2)+ `as` #token+ :* Set (parameter @3 (typedef #device_os))+ `as` #os+ )+ )+ OnConflictDoRaise+ (Returning_ Nil)
+ bench/Gauge/Schema.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}++module Gauge.Schema where++import Squeal.PostgreSQL+import GHC.Generics+import qualified Generics.SOP as SOP+++-- Type++data DeviceOS = Android | IOS+ deriving (Show, Read, Eq, Generic)+-- DeviceOS is converted to PG Enum type+instance SOP.Generic DeviceOS+instance SOP.HasDatatypeInfo DeviceOS++-- Defined extra types for the database+-- Operating system enum+type PGDeviceOS = PG (Enumerated DeviceOS)+type DeviceOSType = 'Typedef PGDeviceOS++-- For composite type+data IPLocation = IPLocation+ { countryShort :: String+ , region :: String+ , city :: String+ }+ deriving (Show, Read, Eq, Generic)++instance SOP.Generic IPLocation+instance SOP.HasDatatypeInfo IPLocation++-- IPLocation Composite type+type PGIPLocation = PG (Composite IPLocation)+type IPLocationType = 'Typedef PGIPLocation++-- SCHEMA++-- Users++type UsersColumns = '[+ "id" ::: 'Def :=> 'NotNull 'PGint8+ , "email" ::: 'NoDef :=> 'NotNull 'PGtext+ , "password" ::: 'NoDef :=> 'NotNull 'PGtext+ , "first_name" ::: 'NoDef :=> 'Null 'PGtext+ , "birthyear" ::: 'NoDef :=> 'Null 'PGint2+ ]++type UsersConstraints = '[+ "pk_users" ::: 'PrimaryKey '["id"]+ , "email" ::: 'Unique '["email"]+ ]++type UsersTable = 'Table (UsersConstraints :=> UsersColumns)++-- User devices+type UserDevicesColumns = '[+ "id" ::: 'Def :=> 'NotNull 'PGint8 -- ID as PK because user might have many same OS devices+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint8+ , "token" ::: 'NoDef :=> 'NotNull 'PGtext+ , "os" ::: 'NoDef :=> 'NotNull PGDeviceOS+ ]++type UserDevicesConstraints = '[+ "pk_user_devices" ::: 'PrimaryKey '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"]+ , "token" ::: 'Unique '["token"]+ ]++type UserDevicesTable = 'Table (UserDevicesConstraints :=> UserDevicesColumns)++-- Schema+-- Make sure to put types before tables, otherwise won't compile+type Schema = '[+ -- Enum types:+ "device_os" ::: DeviceOSType+ -- Composite types:+ , "ip_location" ::: IPLocationType+ -- Tables:+ , "users" ::: UsersTable+ , "user_devices" ::: UserDevicesTable+ ]++type Schemas = '["public" ::: Schema]
exe/Example.hs view
@@ -9,11 +9,17 @@ , TypeOperators #-} -module Main (main, main2) where+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} +module Main (main, main2, upsertUser) where++import Control.Monad.Except (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32)-import Data.Monoid ((<>)) import Data.Text (Text) import Data.Vector (Vector) @@ -23,7 +29,7 @@ import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC -type Schema =+type UserSchema = '[ "users" ::: 'Table ( '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4@@ -32,7 +38,7 @@ ]) , "emails" ::: 'Table ( '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "user" "users" '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4@@ -40,83 +46,239 @@ ]) ] -type Schemas = Public Schema+type PublicSchema = '[ "positive" ::: 'Typedef 'PGfloat4 ] +type OrgSchema =+ '[ "organizations" ::: 'Table (+ '[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ , "type" ::: 'NoDef :=> 'NotNull 'PGtext+ ])+ , "members" ::: 'Table (+ '[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"]+ , "fk_organization" ::: 'ForeignKey '["organization"] "org" "organizations" '["id"] ] :=>+ '[ "member" ::: 'NoDef :=> 'NotNull 'PGint4+ , "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ])+ ]++type Schemas+ = '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ]+ setup :: Definition (Public '[]) Schemas setup =- createTable #users+ createDomain #positive real (#value .> 0 .&& (#value & isNotNull))+ >>>+ createSchema #user+ >>>+ createSchema #org+ >>>+ createTable (#user ! #jokers) ( serial `as` #id :* (text & notNullable) `as` #name :* (vararray int2 & notNullable) `as` #vec ) ( primaryKey #id `as` #pk_users ) >>>- createTable #emails+ alterTableRename (#user ! #jokers) #users+ >>>+ createTable (#user ! #emails) ( serial `as` #id :*- (int & notNullable) `as` #user_id :*- (text & nullable) `as` #email )+ columntypeFrom @Int32 `as` #user_id :*+ columntypeFrom @(Maybe Text) `as` #email ) ( primaryKey #id `as` #pk_emails :*- foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )+ foreignKey #user_id (#user ! #users) #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id )+ >>>+ createTable (#org ! #organizations)+ ( serial `as` #id :*+ (text & notNullable) `as` #name :*+ (text & notNullable) `as` #type )+ ( primaryKey #id `as` #pk_organizations )+ >>>+ createTable (#org ! #members)+ ( notNullable int4 `as` #member :*+ notNullable int4 `as` #organization )+ ( foreignKey #member (#user ! #users) #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_member :*+ foreignKey #organization (#org ! #organizations) #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_organization ) teardown :: Definition Schemas (Public '[])-teardown = dropTable #emails >>> dropTable #users+teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)-insertUser = insertInto #users+insertUser = insertInto (#user ! #users) (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec)) (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly)) insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()-insertEmail = insertInto_ #emails+insertEmail = insertInto_ (#user ! #emails) (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) +insertOrganization :: Manipulation_ Schemas (Text, OrganizationType) (Only Int32)+insertOrganization = insertInto (#org ! #organizations)+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #type))+ (OnConflict (OnConstraint #pk_organizations) DoNothing) (Returning_ (#id `as` #fromOnly))+ getUsers :: Query_ Schemas () User getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)- ( from (table (#users `as` #u)- & innerJoin (table (#emails `as` #e))+ ( from (table ((#user ! #users) `as` #u)+ & innerJoin (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id)) ) -data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }- deriving (Show, GHC.Generic)+getOrganizations :: Query_ Schemas () Organization+getOrganizations = select_+ ( #o ! #id `as` #orgId :*+ #o ! #name `as` #orgName :*+ #o ! #type `as` #orgType+ )+ (from (table (#org ! #organizations `as` #o)))++getOrganizationsBy ::+ forall hsty.+ (ToPG Schemas hsty) =>+ Condition+ 'Ungrouped+ '[]+ '[]+ Schemas+ '[NullPG hsty]+ '["o" ::: ["id" ::: NotNull PGint4, "name" ::: NotNull PGtext, "type" ::: NotNull PGtext]] ->+ Query_ Schemas (Only hsty) Organization+getOrganizationsBy condition =+ select_+ ( #o ! #id `as` #orgId :*+ #o ! #name `as` #orgName :*+ #o ! #type `as` #orgType+ )+ (+ from (table (#org ! #organizations `as` #o))+ & where_ condition+ )++upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) ()+upsertUser = insertInto (#user ! #users `as` #u)+ (Values_ (Set (param @1) `as` #id :* setUser))+ (OnConflict (OnConstraint #pk_users) (DoUpdate setUser [#u ! #id .== param @1]))+ (Returning_ Nil)+ where+ setUser = Set (param @2) `as` #name :* Set (param @3) `as` #vec :* Nil++data User+ = User+ { userName :: Text+ , userEmail :: Maybe Text+ , userVec :: VarArray (Vector (Maybe Int16))+ } deriving (Show, GHC.Generic) instance SOP.Generic User instance SOP.HasDatatypeInfo User users :: [User] users =- [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])- , User "Bob" Nothing (VarArray [Just 2, Nothing])- , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])+ [ User "Alice" (Just "alice@gmail.com") (VarArray [Just 1,Just 2,Nothing])+ , User "Bob" Nothing (VarArray [Nothing,Just (-3)])+ , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3,Nothing, Just 4]) ] +data Organization+ = Organization+ { orgId :: Int32+ , orgName :: Text+ , orgType :: OrganizationType+ } deriving (Show, GHC.Generic)+instance SOP.Generic Organization+instance SOP.HasDatatypeInfo Organization++data OrganizationType+ = ForProfit+ | NonProfit+ deriving (Show, GHC.Generic)+instance SOP.Generic OrganizationType+instance SOP.HasDatatypeInfo OrganizationType++instance IsPG OrganizationType where+ type PG OrganizationType = 'PGtext+instance ToPG db OrganizationType where+ toPG = toPG . toText+ where+ toText ForProfit = "for-profit" :: Text+ toText NonProfit = "non-profit" :: Text++instance FromPG OrganizationType where+ fromPG = do+ value <- fromPG @Text+ fromText value+ where+ fromText "for-profit" = pure ForProfit+ fromText "non-profit" = pure NonProfit+ fromText value = throwError $ "Invalid organization type: \"" <> value <> "\""++organizations :: [Organization]+organizations =+ [ Organization { orgId = 1, orgName = "ACME", orgType = ForProfit }+ , Organization { orgId = 2, orgName = "Haskell Foundation", orgType = NonProfit }+ ]+ session :: (MonadIO pq, MonadPQ Schemas pq) => pq () session = do- liftIO $ Char8.putStrLn "manipulating"- idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])- ids <- traverse (fmap fromOnly . getRow 0) idResults- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))- liftIO $ Char8.putStrLn "querying"+ liftIO $ Char8.putStrLn "===> manipulating"+ userIdResults <- traversePrepared insertUser [(userName user, userVec user) | user <- users]+ userIds <- traverse (fmap fromOnly . getRow 0) (userIdResults :: [Result (Only Int32)])+ traversePrepared_ insertEmail (zip (userIds :: [Int32]) (userEmail <$> users))++ orgIdResults <- traversePrepared+ insertOrganization+ [(orgName organization, orgType organization) | organization <- organizations]+ _ <- traverse (fmap fromOnly . getRow 0) (orgIdResults :: [Result (Only Int32)])++ liftIO $ Char8.putStrLn "===> querying: users" usersResult <- runQuery getUsers usersRows <- getRows usersResult liftIO $ print (usersRows :: [User]) + liftIO $ Char8.putStrLn "===> querying: organizations: all"+ organizationsResult1 <- runQuery getOrganizations+ organizationRows1 <- getRows organizationsResult1+ liftIO $ print (organizationRows1 :: [Organization])++ liftIO $ Char8.putStrLn "===> querying: organizations: by ID (2)"+ organizationsResult2 <- runQueryParams+ (getOrganizationsBy @Int32 ((#o ! #id) .== param @1)) (Only (2 :: Int32))+ organizationRows2 <- getRows organizationsResult2+ liftIO $ print (organizationRows2 :: [Organization])++ liftIO $ Char8.putStrLn "===> querying: organizations: by name (ACME)"+ organizationsResult3 <- runQueryParams+ (getOrganizationsBy @Text ((#o ! #name) .== param @1)) (Only ("ACME" :: Text))+ organizationRows3 <- getRows organizationsResult3+ liftIO $ print (organizationRows3 :: [Organization])++ liftIO $ Char8.putStrLn "===> querying: organizations: by type (non-profit)"+ organizationsResult4 <- runQueryParams+ (getOrganizationsBy @Text ((#o ! #type) .== param @1)) (Only NonProfit)+ organizationRows4 <- getRows organizationsResult4+ liftIO $ print (organizationRows4 :: [Organization])+ main :: IO () main = do- Char8.putStrLn "squeal"+ Char8.putStrLn "===> squeal" connectionString <- pure- "host=localhost port=5432 dbname=exampledb"+ "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Char8.putStrLn $ "connecting to " <> connectionString connection0 <- connectdb connectionString- Char8.putStrLn "setting up schema"++ Char8.putStrLn "===> setting up schema" connection1 <- execPQ (define setup) connection0 connection2 <- execPQ session connection1- Char8.putStrLn "tearing down schema"++ Char8.putStrLn "===> tearing down schema" connection3 <- execPQ (define teardown) connection2 finish connection3 main2 :: IO () main2 =- withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup & pqThen session & pqThen (define teardown)
squeal-postgresql.cabal view
@@ -1,17 +1,17 @@+cabal-version: 2.2 name: squeal-postgresql-version: 0.5.2.0+version: 0.9.2.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: BSD-3-Clause license-file: LICENSE author: Eitan Chatav maintainer: eitan.chatav@gmail.com-copyright: Copyright (c) 2017 Morphism, LLC+copyright: Copyright (c) 2022 Morphism, LLC category: Database build-type: Simple-cabal-version: >=1.18 extra-doc-files: README.md source-repository head@@ -22,20 +22,29 @@ hs-source-dirs: src exposed-modules: Squeal.PostgreSQL- Squeal.PostgreSQL.Alias- Squeal.PostgreSQL.Binary Squeal.PostgreSQL.Definition+ Squeal.PostgreSQL.Definition.Comment+ Squeal.PostgreSQL.Definition.Constraint+ Squeal.PostgreSQL.Definition.Function+ Squeal.PostgreSQL.Definition.Index+ Squeal.PostgreSQL.Definition.Table+ Squeal.PostgreSQL.Definition.Type+ Squeal.PostgreSQL.Definition.Procedure+ Squeal.PostgreSQL.Definition.Schema+ Squeal.PostgreSQL.Definition.View Squeal.PostgreSQL.Expression Squeal.PostgreSQL.Expression.Aggregate- Squeal.PostgreSQL.Expression.Collection+ Squeal.PostgreSQL.Expression.Array Squeal.PostgreSQL.Expression.Comparison+ Squeal.PostgreSQL.Expression.Composite+ Squeal.PostgreSQL.Expression.Default Squeal.PostgreSQL.Expression.Json- Squeal.PostgreSQL.Expression.Literal+ Squeal.PostgreSQL.Expression.Inline Squeal.PostgreSQL.Expression.Logic Squeal.PostgreSQL.Expression.Math Squeal.PostgreSQL.Expression.Null Squeal.PostgreSQL.Expression.Parameter- Squeal.PostgreSQL.Expression.SetOf+ Squeal.PostgreSQL.Expression.Range Squeal.PostgreSQL.Expression.Sort Squeal.PostgreSQL.Expression.Subquery Squeal.PostgreSQL.Expression.Text@@ -43,81 +52,161 @@ Squeal.PostgreSQL.Expression.Time Squeal.PostgreSQL.Expression.Type Squeal.PostgreSQL.Expression.Window- Squeal.PostgreSQL.List Squeal.PostgreSQL.Manipulation- Squeal.PostgreSQL.Migration- Squeal.PostgreSQL.Pool- Squeal.PostgreSQL.PG- Squeal.PostgreSQL.PQ+ Squeal.PostgreSQL.Manipulation.Call+ Squeal.PostgreSQL.Manipulation.Delete+ Squeal.PostgreSQL.Manipulation.Insert+ Squeal.PostgreSQL.Manipulation.Update Squeal.PostgreSQL.Render Squeal.PostgreSQL.Query- Squeal.PostgreSQL.Schema- Squeal.PostgreSQL.Transaction+ Squeal.PostgreSQL.Query.From+ Squeal.PostgreSQL.Query.From.Join+ Squeal.PostgreSQL.Query.From.Set+ Squeal.PostgreSQL.Query.Select+ Squeal.PostgreSQL.Query.Table+ Squeal.PostgreSQL.Query.Values+ Squeal.PostgreSQL.Query.With+ Squeal.PostgreSQL.Session+ Squeal.PostgreSQL.Session.Connection+ Squeal.PostgreSQL.Session.Decode+ Squeal.PostgreSQL.Session.Encode+ Squeal.PostgreSQL.Session.Exception+ Squeal.PostgreSQL.Session.Indexed+ Squeal.PostgreSQL.Session.Migration+ Squeal.PostgreSQL.Session.Monad+ Squeal.PostgreSQL.Session.Oid+ Squeal.PostgreSQL.Session.Pool+ Squeal.PostgreSQL.Session.Result+ Squeal.PostgreSQL.Session.Statement+ Squeal.PostgreSQL.Session.Transaction+ Squeal.PostgreSQL.Session.Transaction.Unsafe+ Squeal.PostgreSQL.Type+ Squeal.PostgreSQL.Type.Alias+ Squeal.PostgreSQL.Type.List+ Squeal.PostgreSQL.Type.PG+ Squeal.PostgreSQL.Type.Schema default-language: Haskell2010 ghc-options: -Wall build-depends:- aeson >= 1.2.4.0- , base >= 4.11.1.0 && < 5.0+ aeson >= 1.4.7.1+ , base >= 4.12.0.0 && < 5.0+ , binary >= 0.8.7.0 , binary-parser >= 0.5.5- , bytestring >= 0.10.8.2- , bytestring-strict-builder >= 0.4.5- , deepseq >= 1.4.3.0- , generics-sop >= 0.3.2.0 && < 0.5.0.0- , mmorph >= 1.1.1+ , bytestring >= 0.10.10.0+ , bytestring-strict-builder >= 0.4.5.3+ , deepseq >= 1.4.4.0+ , exceptions >= 0.10.3+ , free-categories >= 0.2.0.0+ , generics-sop >= 0.5.1.0+ , hashable >= 1.3.0.0+ , iproute >= 1.7.0+ , mmorph >= 1.1.3+ , monad-control >= 1.0.2.3 , mtl >= 2.2.2- , network-ip >= 0.3.0.2- , postgresql-binary >= 0.12.1- , postgresql-libpq >= 0.9.4.1- , records-sop >= 0.1.0.0+ , network-ip >= 0.3.0.3+ , postgresql-binary >= 0.12.2+ , postgresql-libpq >= 0.9.4.2+ , profunctors >= 5.5.2+ , records-sop >= 0.1.0.3 , resource-pool >= 0.2.3.2- , scientific >= 0.3.5.3- , text >= 1.2.3.0- , time >= 1.8.0.2- , transformers >= 0.5.2.0- , unliftio >= 0.2.10- , unliftio-pool >= 0.2.1.0+ , scientific >= 0.3.6.2+ , text >= 1.2.3.2+ , time >= 1.9.3+ , transformers >= 0.5.6.2+ , transformers-base >= 0.4.5.2+ , unliftio >= 0.2.12.1 , uuid-types >= 1.0.3- , vector >= 0.12.0.1+ , vector >= 0.12.1.2 -test-suite squeal-postgresql-doctest+test-suite doctest default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test ghc-options: -Wall- main-is: DocTest.hs+ main-is: Doc.hs build-depends:- base >= 4.10.0.0- , doctest >= 0.11.4+ base >= 4.12.0.0 && < 5.0+ , doctest >= 0.16.3+ if impl(ghc >= 9.0.0)+ buildable: False -test-suite squeal-postgresql-specs+test-suite properties default-language: Haskell2010 type: exitcode-stdio-1.0- hs-source-dirs: test/Specs+ hs-source-dirs: test+ ghc-options: -Wall + main-is: Property.hs+ build-depends:+ base >= 4.12.0.0 && < 5.0+ , bytestring >= 0.10.10.0+ , hedgehog >= 1.0.2+ , generics-sop >= 0.5.1.0+ , mtl >= 2.2.2+ , scientific >= 0.3.6.2+ , squeal-postgresql+ , time >= 1.9.3+ , with-utf8 >= 1.0++test-suite spec+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test ghc-options: -Wall- main-is: Specs.hs- other-modules: ExceptionHandling+ main-is: Spec.hs build-depends:- base >= 4.10.0.0- , async >= 2.2.2- , bytestring >= 0.10.8.2- , generics-sop >= 0.3.1.0- , hspec >= 2.4.8+ async >= 2.2.2+ , base >= 4.12.0.0 && < 5.0+ , bytestring >= 0.10.10.0+ , generics-sop >= 0.5.1.0+ , hspec >= 2.7.1+ , mtl >= 2.2.2 , squeal-postgresql- , text >= 1.2.2.2- , transformers >= 0.5.2.0- , vector >= 0.12.0.1+ , text >= 1.2.3.2+ , vector >= 0.12.1.2 -executable squeal-postgresql-example+benchmark gauge+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Gauge.hs+ other-modules:+ Gauge.DBHelpers+ , Gauge.DBSetup+ , Gauge.Queries+ , Gauge.Schema default-language: Haskell2010+ ghc-options:+ -O2+ -threaded+ "-with-rtsopts=-N"+ -rtsopts+ -funbox-strict-fields+ build-depends:+ base >= 4.12.0.0 && < 5.0+ , bytestring >= 0.10.10.0+ , deepseq >= 1.4.4.0+ , gauge >= 0.2.5+ , generic-random >= 1.3.0.1+ , generics-sop >= 0.5.1.0+ , monad-loops >= 0.4.3+ , mtl >= 2.2.2+ , QuickCheck >= 2.13.2+ , quickcheck-instances >= 0.3.22+ , scientific >= 0.3.6.2+ , squeal-postgresql+ , text >= 1.2.3.2+ , with-utf8 >= 1.0++executable example+ default-language: Haskell2010 hs-source-dirs: exe ghc-options: -Wall main-is: Example.hs build-depends: base >= 4.10.0.0 && < 5.0- , bytestring >= 0.10.8.2- , generics-sop >= 0.3.1.0- , mtl >= 2.2.1+ , bytestring >= 0.10.10.0+ , generics-sop >= 0.5.1.0+ , mtl >= 2.2.2 , squeal-postgresql- , text >= 1.2.2.2- , transformers >= 0.5.2.0- , vector >= 0.12.0.1+ , text >= 1.2.3.2+ , transformers >= 0.5.6.2+ , vector >= 0.12.1.2
src/Squeal/PostgreSQL.hs view
@@ -1,6 +1,6 @@ {-| Module: Squeal.PostgreSQL-Description: Squeal export module+Description: export module Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental@@ -40,11 +40,11 @@ , "email" ::: 'NoDef :=> 'Null 'PGtext ] type EmailsConstraints = '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] type Schema = '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]-type Schemas = Public Schema+type DB = Public Schema :} Notice the use of type operators.@@ -54,7 +54,7 @@ operator. `:=>` is used to pair `TableConstraints` with a `ColumnsType`,-yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,+yielding a `TableType`, or to pair an `Optionality` with a `NullType`, yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator Next, we'll write `Definition`s to set up and tear down the schema. In@@ -66,7 +66,7 @@ >>> :{ let- setup :: Definition (Public '[]) Schemas+ setup :: Definition (Public '[]) DB setup = createTable #users ( serial `as` #id :*@@ -78,7 +78,7 @@ (text & nullable) `as` #email ) ( primaryKey #id `as` #pk_emails :* foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id ) :} We can easily see the generated SQL is unsurprising looking.@@ -87,14 +87,14 @@ CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id")); CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE); -Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@.+Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @DB@. In our `createTable` commands we included `TableConstraint`s to define primary and foreign keys, making them somewhat complex. Our @teardown@ `Definition` is simpler. >>> :{ let- teardown :: Definition Schemas (Public '[])+ teardown :: Definition DB (Public '[]) teardown = dropTable #emails >>> dropTable #users :} @@ -105,25 +105,27 @@ We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and `Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s. ->>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)->>> instance SOP.Generic User->>> instance SOP.HasDatatypeInfo User+>>> :set -XDerivingStrategies -XDeriveAnyClass+>>> :{+data User = User { userName :: Text, userEmail :: Maybe Text }+ deriving stock (Show, GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:} -Next, we'll write `Manipulation_`s to insert @User@s into our two tables.-A `Manipulation_` like `insertInto`, `update` or `deleteFrom`-has three type parameters, the schemas it refers to, input parameters-and an output row. When+Next, we'll write `Statement`s to insert @User@s into our two tables.+A `Statement` has three type parameters, the schemas it refers to,+input parameters and an output row. When we insert into the users table, we will need a parameter for the @name@ field but not for the @id@ field. Since it's serial, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into-the emails table. We can do this in a single `Manipulation_` by using a-`with` statement.+the emails table. We can do this in a single `Statement` by using a+`with` `manipulation`. >>> :{ let- insertUser :: Manipulation_ Schemas User ()- insertUser = with (u `as` #u) e+ insertUser :: Statement DB User ()+ insertUser = manipulation $ with (u `as` #u) e where u = insertInto #users (Values_ (Default `as` #id :* Set (param @1) `as` #name))@@ -134,17 +136,16 @@ :} >>> printSQL insertUser-WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"+WITH "u" AS (INSERT INTO "users" AS "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" AS "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u" -Next we write a `Query_` to retrieve users from the database. We're not+Next we write a `Statement` to retrieve users from the database. We're not interested in the ids here, just the usernames and email addresses. We-need to use an `innerJoin` to get the right result. A `Query_` is like a-`Manipulation_` with the same kind of type parameters.+need to use an `innerJoin` to get the right result. >>> :{ let- getUsers :: Query_ Schemas () User- getUsers = select_+ getUsers :: Statement DB () User+ getUsers = query $ select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail) ( from (table (#users `as` #u) & innerJoin (table (#emails `as` #e))@@ -176,36 +177,54 @@ >>> :{ let- session :: PQ Schemas Schemas IO ()+ session :: PQ DB DB IO () session = do- _ <- traversePrepared_ insertUser users- usersResult <- runQuery getUsers+ executePrepared_ insertUser users+ usersResult <- execute getUsers usersRows <- getRows usersResult- liftIO $ print (usersRows :: [User])+ liftIO $ print usersRows in- withConnection "host=localhost port=5432 dbname=exampledb" $+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ define setup & pqThen session & pqThen (define teardown) :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]++This should get you up and running with Squeal. Once you're writing more complicated+queries and need a deeper understanding of Squeal's types and how everything+fits together, check out the <https://github.com/morphismtech/squeal/blob/dev/squeal-core-concepts-handbook.md Core Concepts Handbook>+in the toplevel of Squeal's Git repo. -}-module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where+module Squeal.PostgreSQL+ ( module X+ , RenderSQL (..)+ , printSQL+ ) where -import Squeal.PostgreSQL.Alias as X-import Squeal.PostgreSQL.Binary as X import Squeal.PostgreSQL.Definition as X+import Squeal.PostgreSQL.Definition.Comment as X+import Squeal.PostgreSQL.Definition.Constraint as X+import Squeal.PostgreSQL.Definition.Function as X+import Squeal.PostgreSQL.Definition.Index as X+import Squeal.PostgreSQL.Definition.Procedure as X+import Squeal.PostgreSQL.Definition.Schema as X+import Squeal.PostgreSQL.Definition.Table as X+import Squeal.PostgreSQL.Definition.Type as X+import Squeal.PostgreSQL.Definition.View as X import Squeal.PostgreSQL.Expression as X import Squeal.PostgreSQL.Expression.Aggregate as X-import Squeal.PostgreSQL.Expression.Collection as X+import Squeal.PostgreSQL.Expression.Array as X import Squeal.PostgreSQL.Expression.Comparison as X+import Squeal.PostgreSQL.Expression.Composite as X+import Squeal.PostgreSQL.Expression.Default as X import Squeal.PostgreSQL.Expression.Json as X-import Squeal.PostgreSQL.Expression.Literal as X+import Squeal.PostgreSQL.Expression.Inline as X import Squeal.PostgreSQL.Expression.Logic as X import Squeal.PostgreSQL.Expression.Math as X import Squeal.PostgreSQL.Expression.Null as X import Squeal.PostgreSQL.Expression.Parameter as X-import Squeal.PostgreSQL.Expression.SetOf as X+import Squeal.PostgreSQL.Expression.Range as X import Squeal.PostgreSQL.Expression.Sort as X import Squeal.PostgreSQL.Expression.Subquery as X import Squeal.PostgreSQL.Expression.Text as X@@ -213,13 +232,35 @@ import Squeal.PostgreSQL.Expression.Time as X import Squeal.PostgreSQL.Expression.Type as X import Squeal.PostgreSQL.Expression.Window as X-import Squeal.PostgreSQL.List as X import Squeal.PostgreSQL.Manipulation as X-import Squeal.PostgreSQL.Migration as X-import Squeal.PostgreSQL.PG as X-import Squeal.PostgreSQL.Pool as X-import Squeal.PostgreSQL.PQ as X+import Squeal.PostgreSQL.Manipulation.Call as X+import Squeal.PostgreSQL.Manipulation.Delete as X+import Squeal.PostgreSQL.Manipulation.Insert as X+import Squeal.PostgreSQL.Manipulation.Update as X import Squeal.PostgreSQL.Query as X+import Squeal.PostgreSQL.Query.From as X+import Squeal.PostgreSQL.Query.From.Join as X+import Squeal.PostgreSQL.Query.From.Set as X+import Squeal.PostgreSQL.Query.Select as X+import Squeal.PostgreSQL.Query.Table as X+import Squeal.PostgreSQL.Query.Values as X+import Squeal.PostgreSQL.Query.With as X import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)-import Squeal.PostgreSQL.Schema as X-import Squeal.PostgreSQL.Transaction as X+import Squeal.PostgreSQL.Session as X+import Squeal.PostgreSQL.Session.Connection as X+import Squeal.PostgreSQL.Session.Decode as X+import Squeal.PostgreSQL.Session.Encode as X+import Squeal.PostgreSQL.Session.Exception as X+import Squeal.PostgreSQL.Session.Indexed as X+import Squeal.PostgreSQL.Session.Migration as X+import Squeal.PostgreSQL.Session.Monad as X+import Squeal.PostgreSQL.Session.Oid as X+import Squeal.PostgreSQL.Session.Pool as X+import Squeal.PostgreSQL.Session.Result as X+import Squeal.PostgreSQL.Session.Statement as X+import Squeal.PostgreSQL.Session.Transaction as X+import Squeal.PostgreSQL.Type as X+import Squeal.PostgreSQL.Type.Alias as X+import Squeal.PostgreSQL.Type.List as X+import Squeal.PostgreSQL.Type.PG as X+import Squeal.PostgreSQL.Type.Schema as X
− src/Squeal/PostgreSQL/Alias.hs
@@ -1,249 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Alias-Description: Aliases-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--This module embeds Postgres's alias system in Haskell in-a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,-Squeal can reference aliases by prepending with a @#@.--}--{-# LANGUAGE- AllowAmbiguousTypes- , ConstraintKinds- , DeriveAnyClass- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , LambdaCase- , OverloadedStrings- , QuantifiedConstraints- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TypeApplications- , TypeFamilyDependencies- , TypeInType- , TypeOperators- , UndecidableInstances- , UndecidableSuperClasses-#-}--module Squeal.PostgreSQL.Alias- ( (:::)- , Alias (..)- , IsLabel (..)- , Aliased (As)- , Aliasable (as)- , renderAliased- , Has- , HasUnique- , HasAll- , HasIn- , QualifiedAlias (..)- , IsQualified (..)- -- * Grouping- , Grouping (..)- , GroupedBy- ) where--import Control.DeepSeq-import Data.ByteString (ByteString)-import Data.String (fromString)-import GHC.OverloadedLabels-import GHC.TypeLits--import qualified Generics.SOP as SOP-import qualified GHC.Generics as GHC--import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Render---- $setup--- >>> import Squeal.PostgreSQL---- | The alias operator `:::` is like a promoted version of `As`,--- a type level pair between an alias and some type.-type (:::) (alias :: Symbol) ty = '(alias,ty)-infixr 6 :::----- | `Grouping` is an auxiliary namespace, created by--- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used--- for typesafe aggregation-data Grouping- = Ungrouped -- ^ no aggregation permitted- | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped--{- | A `GroupedBy` constraint indicates that a table qualified column is-a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,-may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.--}-class (KnownSymbol table, KnownSymbol column)- => GroupedBy table column bys where-instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)- => GroupedBy table column ('(table,column) ': bys)-instance {-# OVERLAPPABLE #-}- ( KnownSymbol table- , KnownSymbol column- , GroupedBy table column bys- ) => GroupedBy table column (tabcol ': bys)---- | `Alias`es are proxies for a type level string or `Symbol`--- and have an `IsLabel` instance so that with @-XOverloadedLabels@------ >>> :set -XOverloadedLabels--- >>> #foobar :: Alias "foobar"--- Alias-data Alias (alias :: Symbol) = Alias- deriving (Eq,GHC.Generic,Ord,Show,NFData)-instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where- fromLabel = Alias-instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where- fromLabel = fromLabel SOP.:* Nil--- | >>> printSQL (#jimbob :: Alias "jimbob")--- "jimbob"-instance KnownSymbol alias => RenderSQL (Alias alias) where- renderSQL = doubleQuoted . fromString . symbolVal---- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])--- "jimbob", "kandi"-instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where- renderSQL- = commaSeparated- . SOP.hcollapse- . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)---- | The `As` operator is used to name an expression. `As` is like a demoted--- version of `:::`.------ >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)--- As (Just "hello") Alias-data Aliased expression aliased where- As- :: KnownSymbol alias- => expression ty- -> Alias alias- -> Aliased expression (alias ::: ty)-deriving instance Show (expression ty)- => Show (Aliased expression (alias ::: ty))-deriving instance Eq (expression ty)- => Eq (Aliased expression (alias ::: ty))-deriving instance Ord (expression ty)- => Ord (Aliased expression (alias ::: ty))-instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)- => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where- fromLabel = fromLabel @alias2 `As` fromLabel @alias1---- | The `Aliasable` class provides a way to scrap your `Nil`s--- in an `NP` list of `Aliased` expressions.-class KnownSymbol alias => Aliasable alias expression aliased- | aliased -> expression- , aliased -> alias- where as :: expression -> Alias alias -> aliased-instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias- (expression ty)- (Aliased expression aliased)- where- as = As-instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias- (expression ty)- (NP (Aliased expression) tys)- where- expression `as` alias = expression `As` alias SOP.:* Nil---- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")--- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)--- "Just AS \"an_int\""-renderAliased- :: (forall ty. expression ty -> ByteString)- -> Aliased expression aliased- -> ByteString-renderAliased render (expression `As` alias) =- render expression <> " AS " <> renderSQL alias---- | @HasUnique alias fields field@ is a constraint that proves that--- @fields@ is a singleton of @alias ::: field@.-type HasUnique alias fields field = fields ~ '[alias ::: field]---- | @Has alias fields field@ is a constraint that proves that--- @fields@ has a field of @alias ::: field@, inferring @field@--- from @alias@ and @fields@.-class KnownSymbol alias =>- Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)- | alias fields -> field where-instance {-# OVERLAPPING #-} KnownSymbol alias- => Has alias (alias ::: field ': fields) field-instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)- => Has alias (field' ': fields) field--{-| @HasIn fields (alias ::: field)@ is a constraint that proves that-@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to-choose which subfields to update.--}-class HasIn fields field where-instance (Has alias fields field) => HasIn fields (alias ::: field) where---- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer--- a list of @subfields@.-class- ( SOP.All KnownSymbol aliases- ) => HasAll- (aliases :: [Symbol])- (fields :: [(Symbol,kind)])- (subfields :: [(Symbol,kind)])- | aliases fields -> subfields where-instance {-# OVERLAPPING #-} HasAll '[] fields '[]-instance {-# OVERLAPPABLE #-}- (Has alias fields field, HasAll aliases fields subfields)- => HasAll (alias ': aliases) fields (alias ::: field ': subfields)---- | Analagous to `IsLabel`, the constraint--- `IsQualified` defines `!` for a column alias qualified--- by a table alias.-class IsQualified table column expression where- (!) :: Alias table -> Alias column -> expression- infixl 9 !-instance IsQualified table column (Alias table, Alias column) where (!) = (,)--{-| `QualifiedAlias`es enables multi-schema support by allowing a reference-to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`-or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,-a qualifier of @public@ is provided.-->>> :{-let- alias1 :: QualifiedAlias "sch" "tab"- alias1 = #sch ! #tab- alias2 :: QualifiedAlias "public" "vw"- alias2 = #vw-in printSQL alias1 >> printSQL alias2-:}-"sch"."tab"-"vw"--}-data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias- deriving (Eq,GHC.Generic,Ord,Show,NFData)-instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where- _!_ = QualifiedAlias-instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where- fromLabel = QualifiedAlias-instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>- IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where- _!_ = QualifiedAlias `As` Alias-instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>- IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where- fromLabel = QualifiedAlias `As` Alias--instance (KnownSymbol q, KnownSymbol a)- => RenderSQL (QualifiedAlias q a) where- renderSQL _ =- let- qualifier = renderSQL (Alias @q)- alias = renderSQL (Alias @a)- in- if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
− src/Squeal/PostgreSQL/Binary.hs
@@ -1,757 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Binary-Description: Binary encoding and decoding-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--This module provides binary encoding and decoding between Haskell and PostgreSQL types.--Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely-do not need to define your own instances to decode retrieved rows into Haskell values or-to encode Haskell values into statement parameters.--Let's see some examples. We'll need some imports-->>> import Data.Int (Int16)->>> import Data.Text (Text)->>> import Control.Monad (void)->>> import Control.Monad.IO.Class (liftIO)->>> import Squeal.PostgreSQL--Define a Haskell datatype @Row@ that will serve as both the input and output of a simple-round trip query.-->>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)->>> instance Generic Row->>> instance HasDatatypeInfo Row->>> :{-let- roundTrip :: Query_ (Public '[]) Row Row- roundTrip = values_ $- parameter @1 int2 `as` #col1 :*- parameter @2 text `as` #col2 :*- parameter @3 bool `as` #col3-:}--So long as we can encode the parameters and then decode the result of the query,-the input and output should be equal.-->>> let input = Row 2 "hi" (Just True)->>> :{-withConnection "host=localhost port=5432 dbname=exampledb" $ do- result <- runQueryParams roundTrip input- Just output <- firstRow result- liftIO . print $ input == output-:}-True--In addition to being able to encode and decode basic Haskell types-like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to-Postgres array, enumerated and composite types and json. Let's see another example,-this time using the `Vector` type which corresponds to variable length arrays-and homogeneous tuples which correspond to fixed length arrays. We can even-create multi-dimensional fixed length arrays.-->>> :{-data Row = Row- { col1 :: VarArray (Vector Int16)- , col2 :: FixArray (Maybe Int16,Maybe Int16)- , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))- } deriving (Eq, GHC.Generic)-:}-->>> instance Generic Row->>> instance HasDatatypeInfo Row--Once again, we define a simple round trip query.-->>> :{-let- roundTrip :: Query_ (Public '[]) Row Row- roundTrip = values_ $- parameter @1 (int2 & vararray) `as` #col1 :*- parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*- parameter @3 (int2 & fixarray @'[3,2]) `as` #col3-:}-->>> :set -XOverloadedLists->>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))->>> :{-withConnection "host=localhost port=5432 dbname=exampledb" $ do- result <- runQueryParams roundTrip input- Just output <- firstRow result- liftIO . print $ input == output-:}-True--Enumerated (enum) types are data types that comprise a static, ordered set of values.-They are equivalent to Haskell algebraic data types whose constructors are nullary.-An example of an enum type might be the days of the week,-or a set of status values for a piece of data.-->>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)->>> instance Generic Schwarma->>> instance HasDatatypeInfo Schwarma--A composite type represents the structure of a row or record;-it is essentially just a list of field names and their data types.-->>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)->>> instance Generic Person->>> instance HasDatatypeInfo Person->>> instance Aeson.FromJSON Person->>> instance Aeson.ToJSON Person--We can create the equivalent Postgres types directly from their Haskell types.-->>> :{-type Schema =- '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))- , "person" ::: 'Typedef (PG (Composite Person))- ]-:}-->>> :{-let- setup :: Definition (Public '[]) (Public Schema)- setup =- createTypeEnumFrom @Schwarma #schwarma >>>- createTypeCompositeFrom @Person #person-:}--Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@-with enumerated, composite or json types in Postgres. First create a Haskell-@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.-->>> :{-data Row = Row- { schwarma :: Enumerated Schwarma- , person1 :: Composite Person- , person2 :: Json Person- } deriving (Eq, GHC.Generic)-:}-->>> instance Generic Row->>> instance HasDatatypeInfo Row->>> :{-let- input = Row- (Enumerated Chicken)- (Composite (Person "Faisal" 24))- (Json (Person "Ahmad" 48))-:}--Once again, define a round trip query.-->>> :{-let- roundTrip :: Query_ (Public Schema) Row Row- roundTrip = values_ $- parameter @1 (typedef #schwarma) `as` #schwarma :*- parameter @2 (typedef #person) `as` #person1 :*- parameter @3 json `as` #person2-:}--Finally, we can drop our type definitions.-->>> :{-let- teardown :: Definition (Public Schema) (Public '[])- teardown = dropType #schwarma >>> dropType #person-:}--Now let's run it.-->>> :{-let- session = do- result <- runQueryParams roundTrip input- Just output <- firstRow result- liftIO . print $ input == output-in- withConnection "host=localhost port=5432 dbname=exampledb" $- define setup- & pqThen session- & pqThen (define teardown)-:}-True--}--{-# LANGUAGE- AllowAmbiguousTypes- , DeriveFoldable- , DeriveFunctor- , DeriveGeneric- , DeriveTraversable- , DefaultSignatures- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , LambdaCase- , OverloadedStrings- , MultiParamTypeClasses- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , TypeInType- , TypeOperators- , UndecidableInstances- , UndecidableSuperClasses-#-}--module Squeal.PostgreSQL.Binary- ( -- * Encoding- ToParam (..)- , ToParams (..)- , ToNullityParam (..)- , ToField (..)- , ToFixArray (..)- -- * Decoding- , FromValue (..)- , FromRow (..)- , FromField (..)- , FromFixArray (..)- -- * Only- , Only (..)- -- * Oid- , HasOid (..)- , HasAliasedOid (..)- ) where--import BinaryParser-import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)-import Control.Arrow (left)-import Control.Monad-import Data.Int-import Data.Kind-import Data.Scientific-import Data.Time-import Data.UUID.Types-import Data.Vector (Vector)-import Data.Word-import Generics.SOP-import Generics.SOP.Record-import GHC.TypeLits-import Network.IP.Addr--import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Lazy as Lazy (ByteString)-import qualified Data.ByteString.Lazy as Lazy.ByteString-import qualified Data.ByteString as Strict (ByteString)-import qualified Data.Text.Lazy as Lazy (Text)-import qualified Data.Text as Strict (Text)-import qualified Data.Text as Strict.Text-import qualified Data.Vector as Vector-import qualified GHC.Generics as GHC-import qualified PostgreSQL.Binary.Decoding as Decoding-import qualified PostgreSQL.Binary.Encoding as Encoding--import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.PG-import Squeal.PostgreSQL.Schema---- | A `ToParam` constraint gives an encoding of a Haskell `Type` into--- 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 Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents-instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid-instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet-instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8-instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict-instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy-instance ToParam String 'PGtext where- toParam = K . Encoding.text_strict . Strict.Text.pack-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 Aeson.Value 'PGjson where toParam = K . Encoding.json_ast-instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast-instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where- toParam = K . Encoding.json_bytes- . Lazy.ByteString.toStrict . Aeson.encode . getJson-instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where- toParam = K . Encoding.jsonb_bytes- . Lazy.ByteString.toStrict . Aeson.encode . getJsonb-instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)- => ToParam (VarArray [x]) ('PGvararray ty) where- toParam = K- . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)- . getVarArray-instance (ToParam x pg, HasOid pg)- => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where- toParam = K- . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)- . getVarArray-instance (ToParam x pg, HasOid pg)- => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where- toParam = K- . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)- . getVarArray-instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)- => ToParam (FixArray x) ('PGfixarray dims ty) where- toParam = K . Encoding.array (oid @pg)- . unK . unK . toFixArray @x @dims @ty . getFixArray-instance- ( IsEnumType x- , HasDatatypeInfo x- , LabelsPG x ~ labels- ) => ToParam (Enumerated x) ('PGenum labels) where- toParam =- let- gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String- gshowConstructor Nil _ = ""- gshowConstructor (constructor :* _) (SOP (Z _)) =- constructorName constructor- gshowConstructor (_ :* constructors) (SOP (S xs)) =- gshowConstructor constructors (SOP xs)- in- K . Encoding.text_strict- . Strict.Text.pack- . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))- . from- . getEnumerated-instance- ( SListI fields- , IsRecord x xs- , AllZip ToField xs fields- , All HasAliasedOid fields- ) => ToParam (Composite x) ('PGcomposite fields) where- toParam =- let-- encoders = htrans (Proxy @ToField) toField-- composite- :: All HasAliasedOid row- => NP (K (Maybe Encoding.Encoding)) row- -> K Encoding.Encoding ('PGcomposite row)- composite fields = K $- -- <number of fields: 4 bytes>- -- [for each field]- -- <OID of field's type: sizeof(Oid) bytes>- -- [if value is NULL]- -- <-1: 4 bytes>- -- [else]- -- <length of value: 4 bytes>- -- <value: <length> bytes>- -- [end if]- -- [end for]- int32BE (fromIntegral (lengthSList (Proxy @xs))) <>- let- each- :: HasAliasedOid field- => K (Maybe Encoding.Encoding) field- -> Encoding.Encoding- each (K field :: K (Maybe Encoding.Encoding) field) =- word32BE (aliasedOid @field)- <> case field of- Nothing -> int64BE (-1)- Just value ->- int32BE (fromIntegral (builderLength value))- <> value- in- hcfoldMap (Proxy @HasAliasedOid) each fields-- in- composite . encoders . toRecord . getComposite---- | The object identifier of a `PGType`.------ >>> :set -XTypeApplications--- >>> oid @'PGbool--- 16-class HasOid (ty :: PGType) where oid :: Word32-instance HasOid 'PGbool where oid = 16-instance HasOid 'PGint2 where oid = 21-instance HasOid 'PGint4 where oid = 23-instance HasOid 'PGint8 where oid = 20-instance HasOid 'PGnumeric where oid = 1700-instance HasOid 'PGfloat4 where oid = 700-instance HasOid 'PGfloat8 where oid = 701-instance HasOid ('PGchar n) where oid = 18-instance HasOid ('PGvarchar n) where oid = 1043-instance HasOid 'PGtext where oid = 25-instance HasOid 'PGbytea where oid = 17-instance HasOid 'PGtimestamp where oid = 1114-instance HasOid 'PGtimestamptz where oid = 1184-instance HasOid 'PGdate where oid = 1082-instance HasOid 'PGtime where oid = 1083-instance HasOid 'PGtimetz where oid = 1266-instance HasOid 'PGinterval where oid = 1186-instance HasOid 'PGuuid where oid = 2950-instance HasOid 'PGinet where oid = 869-instance HasOid 'PGjson where oid = 114-instance HasOid 'PGjsonb where oid = 3802---- | Lifts a `HasOid` constraint to a field.-class HasAliasedOid (field :: (Symbol, NullityType)) where- aliasedOid :: Word32-instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where- aliasedOid = oid @ty---- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into--- into the binary format of a PostgreSQL `NullityType`.-class ToNullityParam (x :: Type) (ty :: NullityType) where- toNullityParam :: x -> K (Maybe Encoding.Encoding) ty-instance ToParam x pg => ToNullityParam x ('NotNull pg) where- toNullityParam = K . Just . unK . toParam @x @pg-instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where- toNullityParam = K . fmap (unK . toParam @x @pg)---- | A `ToField` constraint lifts the `ToParam` parser--- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,--- encoding `Null`s to `Maybe`s. You should not define instances for--- `FromField`, just use the provided instances.-class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where- toField :: P x -> K (Maybe Encoding.Encoding) field-instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where- toField (P x) = K . unK $ toNullityParam @x @ty x---- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`--- into the binary format of a PostgreSQL fixed-length array.--- You should not define instances for--- `ToFixArray`, just use the provided instances.-class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where- toFixArray :: x -> K (K Encoding.Array dims) array-instance ToNullityParam x ty => ToFixArray x '[] ty where- toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK- . toNullityParam @x @ty-instance- ( IsProductType product xs- , Length xs ~ dim- , All ((~) x) xs- , ToFixArray x dims ty )- => ToFixArray product (dim ': dims) ty where- toFixArray = K . K . Encoding.dimensionArray foldlN- (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from---- | A `ToParams` constraint generically sequences the encodings of `Type`s--- of the fields of a tuple or record to a row of `ColumnType`s. You should--- not define instances of `ToParams`. Instead define `SOP.Generic` instances--- which in turn provide `ToParams` instances.-class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where- -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]- -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)- -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil- --- -- >>> :set -XDeriveGeneric- -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic- -- >>> instance Generic Tuple- -- >>> toParams @Tuple @Params (Tuple False (Just 0))- -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil- toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys-instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)- => ToParams x tys where- toParams- = htrans (Proxy @ToNullityParam) (toNullityParam . 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 = Id <$> fromValue @'PGint2- fromValue :: 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 'PGmoney Money where fromValue = Money <$> Decoding.int-instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid-instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet-instance FromValue ('PGchar 1) Char where fromValue = Decoding.char-instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict-instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy-instance FromValue 'PGtext String where- fromValue = Strict.Text.unpack <$> Decoding.text_strict-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 Aeson.Value where fromValue = Decoding.json_ast-instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast-instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where- fromValue = Json <$>- Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)-instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where- fromValue = Jsonb <$>- Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)-instance FromValue pg y- => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where- fromValue =- let- rep n x = VarArray <$> Vector.replicateM n x- in- Decoding.array $ Decoding.dimensionArray rep- (fromFixArray @'[] @('NotNull pg))-instance FromValue pg y- => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where- fromValue =- let- rep n x = VarArray <$> Vector.replicateM n x- in- Decoding.array $ Decoding.dimensionArray rep- (fromFixArray @'[] @('Null pg))-instance FromValue pg y- => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where- fromValue =- let- rep n x = VarArray <$> replicateM n x- in- Decoding.array $ Decoding.dimensionArray rep- (fromFixArray @'[] @('NotNull pg))-instance FromValue pg y- => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where- fromValue =- let- rep n x = VarArray <$> replicateM n x- in- Decoding.array $ Decoding.dimensionArray rep- (fromFixArray @'[] @('Null pg))-instance FromFixArray dims ty y- => FromValue ('PGfixarray dims ty) (FixArray y) where- fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)-instance- ( IsEnumType y- , HasDatatypeInfo y- , LabelsPG y ~ labels- ) => FromValue ('PGenum labels) (Enumerated y) where- fromValue =- let- greadConstructor- :: All ((~) '[]) xss- => NP ConstructorInfo xss- -> String- -> Maybe (SOP I xss)- greadConstructor Nil _ = Nothing- greadConstructor (constructor :* constructors) name =- if name == constructorName constructor- then Just (SOP (Z Nil))- else SOP . S . unSOP <$> greadConstructor constructors name- in- fmap Enumerated- . Decoding.enum- $ fmap to- . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))- . Strict.Text.unpack-instance- ( FromRow fields y- ) => FromValue ('PGcomposite fields) (Composite y) where- fromValue =- let- -- <number of fields: 4 bytes>- -- [for each field]- -- <OID of field's type: sizeof(Oid) bytes>- -- [if value is NULL]- -- <-1: 4 bytes>- -- [else]- -- <length of value: 4 bytes>- -- <value: <length> bytes>- -- [end if]- -- [end for]- composite = Decoding.valueParser $ do- unitOfSize 4- hsequence' $ hpure $ Comp $ do- unitOfSize 4- len <- sized 4 Decoding.int- if len == -1- then return (K Nothing)- else K . Just <$> bytesOfSize len- in- fmap Composite (Decoding.fn (fromRow @fields <=< composite))---- | A `FromField` constraint lifts the `FromValue` parser--- to a decoding of a @(Symbol, NullityType)@ to a `Type`,--- decoding `Null`s to `Maybe`s. You should not define instances for--- `FromField`, just use the provided instances.-class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where- fromField- :: K (Maybe Strict.ByteString) pg- -> (Either Strict.Text :.: P) y-instance FromValue pg y- => FromField (column ::: ('NotNull pg)) (column ::: y) where- fromField = Comp . \case- K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"- K (Just bytestring) -> P <$>- Decoding.valueParser (fromValue @pg) bytestring-instance FromValue pg y- => FromField (column ::: 'Null pg) (column ::: Maybe y) where- fromField = Comp . \case- K Nothing -> Right $ P Nothing- K (Just bytestring) -> P . Just <$>- Decoding.valueParser (fromValue @pg) bytestring---- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`--- from the binary format of a PostgreSQL fixed-length array.--- You should not define instances for--- `FromFixArray`, just use the provided instances.-class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where- fromFixArray :: Decoding.Array y-instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where- fromFixArray = Decoding.valueArray (fromValue @pg @y)-instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where- fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)-instance- ( IsProductType product ys- , Length ys ~ dim- , All ((~) y) ys- , FromFixArray dims ty y )- => FromFixArray (dim ': dims) ty product where- fromFixArray =- let- rep _ = fmap (to . SOP . Z) . replicateMN- in- Decoding.dimensionArray rep (fromFixArray @dims @ty @y)---- | A `FromRow` constraint generically sequences the parsings of the columns--- of a `RowType` into the fields of a record `Type` provided they have--- the same field names. You should not define instances of `FromRow`.--- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn--- provide `FromRow` instances.-class SListI result => FromRow (result :: RowType) y where- -- | >>> :set -XOverloadedStrings- -- >>> import Data.Text- -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show- -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2- -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)- -- >>> instance Generic UserRow- -- >>> instance HasDatatypeInfo UserRow- -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]- -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)- -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"})- fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y-instance- ( SListI result- , IsRecord y ys- , AllZip FromField result ys- ) => FromRow result y where- fromRow- = fmap fromRecord- . hsequence'- . htrans (Proxy @FromField) fromField---------------------------------------------------------- P records---------------------------------------------------------- instance (FromField (col ::: pg) (col ::: hask))--- => FromRow '[col ::: pg] (P (col ::: hask)) where--- fromRow (pg :* Nil) = (unComp . fromField) pg--- instance--- ( row ~ Join row1 row2--- , FromRow row1 hask1--- , FromRow row2 hask2--- , SListI row--- ) => FromRow row (hask1, hask2) where--- fromRow row = case disjoin @row1 @row2 row of--- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2--- instance--- ( row ~ Join row1 row23--- , FromRow row1 hask1--- , FromRow row23 (hask2, hask3)--- , SListI row--- ) => FromRow row (hask1, hask2, hask3) where--- fromRow row = case disjoin @row1 @row23 row of--- (row1, row23) -> do--- hask1 <- fromRow row1--- (hask2, hask3) <- fromRow row23--- return (hask1, hask2, hask3)--- instance--- ( row ~ Join row1 row234--- , FromRow row1 hask1--- , FromRow row234 (hask2, hask3, hask4)--- , SListI row--- ) => FromRow row (hask1, hask2, hask3, hask4) where--- fromRow row = case disjoin @row1 @row234 row of--- (row1, row234) -> do--- hask1 <- fromRow row1--- (hask2, hask3, hask4) <- fromRow row234--- return (hask1, hask2, hask3, hask4)--- instance--- ( row ~ Join row1 row2345--- , FromRow row1 hask1--- , FromRow row2345 (hask2, hask3, hask4, hask5)--- , SListI row--- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where--- fromRow row = case disjoin @row1 @row2345 row of--- (row1, row2345) -> do--- hask1 <- fromRow row1--- (hask2, hask3, hask4, hask5) <- fromRow row2345--- return (hask1, hask2, hask3, hask4, hask5)---- | `Only` is a 1-tuple type, useful for encoding a single parameter with--- `toParams` or decoding a single value with `fromRow`.------ >>> import Data.Text--- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))--- K (Just "foo") :* Nil------ >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)--- Right (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)--foldlN- :: All ((~) x) xs- => (z -> x -> z) -> z -> NP I xs -> z-foldlN f z = \case- Nil -> z- I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs--replicateMN- :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)- => m x -> m (NP I xs)-replicateMN mx = hsequence' $- hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
src/Squeal/PostgreSQL/Definition.hs view
@@ -1,1110 +1,88 @@ {-| 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- AllowAmbiguousTypes- , ConstraintKinds- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , MultiParamTypeClasses- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeInType- , TypeOperators- , UndecidableSuperClasses-#-}--module Squeal.PostgreSQL.Definition- ( -- * Definition- Definition (..)- , (>>>)- , manipDefinition- -- * Tables- -- ** Create- , createSchema- , createSchemaIfNotExists- , createTable- , createTableIfNotExists- , createView- , createTypeEnum- , createTypeEnumFrom- , createTypeComposite- , createTypeCompositeFrom- , FieldTyped (..)- , createDomain- , TableConstraintExpression (..)- , check- , unique- , primaryKey- , foreignKey- , ForeignKeyed- , OnDeleteClause (..)- , OnUpdateClause (..)- -- ** Drop- , dropSchema- , dropTable- , dropView- , dropType- -- ** Alter- , alterTable- , alterTableRename- , AlterTable (..)- , addConstraint- , dropConstraint- , AddColumn (..)- , dropColumn- , renameColumn- , alterColumn- , AlterColumn (..)- , setDefault- , dropDefault- , setNotNull- , dropNotNull- , alterType- -- * Columns- , ColumnTypeExpression (..)- , nullable- , notNullable- , default_- , serial2- , smallserial- , serial4- , serial- , serial8- , bigserial- ) 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.Alias-import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Expression.Logic-import Squeal.PostgreSQL.Expression.Type-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.PG-import Squeal.PostgreSQL.Query-import Squeal.PostgreSQL.Manipulation-import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema---- $setup--- >>> import Squeal.PostgreSQL--{------------------------------------------statements------------------------------------------}---- | A `Definition` is a statement that changes the schemas of the--- database, like a `createTable`, `dropTable`, or `alterTable` command.--- `Definition`s may be composed using the `>>>` operator.-newtype Definition- (schemas0 :: SchemasType)- (schemas1 :: SchemasType)- = UnsafeDefinition { renderDefinition :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)--instance RenderSQL (Definition schemas0 schemas1) where- renderSQL = renderDefinition--instance Category Definition where- id = UnsafeDefinition ";"- ddl1 . ddl0 = UnsafeDefinition $- renderSQL ddl0 <> "\n" <> renderSQL ddl1---- | A `Manipulation` without input or output can be run as a statement--- along with other `Definition`s, by embedding it using `manipDefinition`.-manipDefinition- :: Manipulation '[] schemas '[] '[]- -- ^ no input or output- -> Definition schemas schemas-manipDefinition = UnsafeDefinition . (<> ";") . renderSQL--{------------------------------------------CREATE statements------------------------------------------}--{- |-`createSchema` enters a new schema into the current database.-The schema name must be distinct from the name of any existing schema-in the current database.--A schema is essentially a namespace: it contains named objects-(tables, data types, functions, and operators) whose names-can duplicate those of other objects existing in other schemas.-Named objects are accessed by `QualifiedAlias`es with the schema-name as a prefix.--}-createSchema- :: KnownSymbol sch- => Alias sch- -> Definition schemas (Create sch '[] schemas)-createSchema sch = UnsafeDefinition $- "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"--{- | Idempotent version of `createSchema`. -}-createSchemaIfNotExists- :: (KnownSymbol sch, Has sch schemas schema)- => Alias sch- -> Definition schemas schemas-createSchemaIfNotExists sch = UnsafeDefinition $- "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"- <+> renderSQL sch <> ";"--{- | `createTable` adds a table to the schema.-->>> :set -XOverloadedLabels->>> :{-type Table = '[] :=>- '[ "a" ::: 'NoDef :=> 'Null 'PGint4- , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]-:}-->>> :{-let- setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])- setup = createTable #tab- (nullable int `as` #a :* nullable real `as` #b) Nil-in printSQL setup-:}-CREATE TABLE "tab" ("a" int NULL, "b" real NULL);--}-createTable- :: ( KnownSymbol sch- , KnownSymbol tab- , columns ~ (col ': cols)- , SOP.SListI columns- , SOP.SListI constraints- , Has sch schemas0 schema0- , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )- => QualifiedAlias sch tab -- ^ the name of the table to add- -> NP (Aliased (ColumnTypeExpression schemas0)) columns- -- ^ the names and datatype of each column- -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints- -- ^ constraints that must hold for the table- -> Definition schemas0 schemas1-createTable tab columns constraints = UnsafeDefinition $- "CREATE TABLE" <+> renderCreation tab columns constraints--{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.-Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.-`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in-the `Category` of `Definition`s.-->>> :set -XOverloadedLabels -XTypeApplications->>> :{-type Table = '[] :=>- '[ "a" ::: 'NoDef :=> 'Null 'PGint4- , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]-:}-->>> type Schemas = Public '["tab" ::: 'Table Table]-->>> :{-let- setup :: Definition Schemas Schemas- setup = createTableIfNotExists #tab- (nullable int `as` #a :* nullable real `as` #b) Nil-in printSQL setup-:}-CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);--}-createTableIfNotExists- :: ( Has sch schemas schema- , Has tab schema ('Table (constraints :=> columns))- , SOP.SListI columns- , SOP.SListI constraints )- => QualifiedAlias sch tab -- ^ the name of the table to add- -> NP (Aliased (ColumnTypeExpression schemas)) columns- -- ^ the names and datatype of each column- -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints- -- ^ constraints that must hold for the table- -> Definition schemas schemas-createTableIfNotExists tab columns constraints = UnsafeDefinition $- "CREATE TABLE IF NOT EXISTS"- <+> renderCreation tab columns constraints---- helper function for `createTable` and `createTableIfNotExists`-renderCreation- :: ( KnownSymbol sch- , KnownSymbol tab- , SOP.SListI columns- , SOP.SListI constraints )- => QualifiedAlias sch tab -- ^ the name of the table to add- -> NP (Aliased (ColumnTypeExpression schemas0)) columns- -- ^ the names and datatype of each column- -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints- -- ^ constraints that must hold for the table- -> ByteString-renderCreation tab columns constraints = renderSQL tab- <+> parenthesized- ( renderCommaSeparated renderColumnDef columns- <> ( case constraints of- Nil -> ""- _ -> ", " <>- renderCommaSeparated renderConstraint constraints ) )- <> ";"- where- renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString- renderColumnDef (ty `As` column) =- renderSQL column <+> renderColumnTypeExpression ty- renderConstraint- :: Aliased (TableConstraintExpression sch tab schemas) constraint- -> ByteString- renderConstraint (constraint `As` alias) =- "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint---- | Data types are a way to limit the kind of data that can be stored in a--- table. For many applications, however, the constraint they provide is--- 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 TableConstraintExpression- (sch :: Symbol)- (tab :: Symbol)- (schemas :: SchemasType)- (constraint :: TableConstraint)- = UnsafeTableConstraintExpression- { renderTableConstraintExpression :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL- (TableConstraintExpression sch tab schemas constraint) where- renderSQL = renderTableConstraintExpression--{-| A `check` constraint is the most generic `TableConstraint` type.-It allows you to specify that the value in a certain column must satisfy-a Boolean (truth-value) expression.-->>> :{-type Schema = '[- "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[- "a" ::: 'NoDef :=> 'NotNull 'PGint4,- "b" ::: 'NoDef :=> 'NotNull 'PGint4- ])]-:}-->>> :{-let- definition :: Definition (Public '[]) (Public Schema)- definition = createTable #tab- ( (int & notNullable) `as` #a :*- (int & notNullable) `as` #b )- ( check (#a :* #b) (#a .> #b) `as` #inequality )-:}-->>> printSQL definition-CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));--}-check- :: ( Has sch schemas schema- , Has tab schema ('Table table)- , HasAll aliases (TableToRow table) subcolumns )- => NP Alias aliases- -- ^ specify the subcolumns which are getting checked- -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])- -- ^ a closed `Condition` on those subcolumns- -> TableConstraintExpression sch tab schemas ('Check aliases)-check _cols condition = UnsafeTableConstraintExpression $- "CHECK" <+> parenthesized (renderSQL condition)--{-| A `unique` constraint ensure that the data contained in a column,-or a group of columns, is unique among all the rows in the table.-->>> :{-type Schema = '[- "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[- "a" ::: 'NoDef :=> 'Null 'PGint4,- "b" ::: 'NoDef :=> 'Null 'PGint4- ])]-:}-->>> :{-let- definition :: Definition (Public '[]) (Public Schema)- definition = createTable #tab- ( (int & nullable) `as` #a :*- (int & nullable) `as` #b )- ( unique (#a :* #b) `as` #uq_a_b )-:}-->>> printSQL definition-CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));--}-unique- :: ( Has sch schemas schema- , Has tab schema('Table table)- , HasAll aliases (TableToRow table) subcolumns )- => NP Alias aliases- -- ^ specify subcolumns which together are unique for each row- -> TableConstraintExpression sch tab schemas ('Unique aliases)-unique columns = UnsafeTableConstraintExpression $- "UNIQUE" <+> parenthesized (renderSQL columns)--{-| A `primaryKey` constraint indicates that a column, or group of columns,-can be used as a unique identifier for rows in the table.-This requires that the values be both unique and not null.-->>> :{-type Schema = '[- "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[- "id" ::: 'Def :=> 'NotNull 'PGint4,- "name" ::: 'NoDef :=> 'NotNull 'PGtext- ])]-:}-->>> :{-let- definition :: Definition (Public '[]) (Public Schema)- definition = createTable #tab- ( serial `as` #id :*- (text & notNullable) `as` #name )- ( primaryKey #id `as` #pk_id )-:}-->>> printSQL definition-CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));--}-primaryKey- :: ( Has sch schemas schema- , Has tab schema ('Table table)- , HasAll aliases (TableToColumns table) subcolumns- , AllNotNull subcolumns )- => NP Alias aliases- -- ^ specify the subcolumns which together form a primary key.- -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)-primaryKey columns = UnsafeTableConstraintExpression $- "PRIMARY KEY" <+> parenthesized (renderSQL columns)--{-| A `foreignKey` specifies that the values in a column-(or a group of columns) must match the values appearing in some row of-another table. We say this maintains the referential integrity-between two related tables.-->>> :{-type Schema =- '[ "users" ::: 'Table (- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- ])- , "emails" ::: 'Table (- '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4- , "email" ::: 'NoDef :=> 'Null 'PGtext- ])- ]-:}-->>> :{-let- setup :: Definition (Public '[]) (Public Schema)- setup =- createTable #users- ( serial `as` #id :*- (text & notNullable) `as` #name )- ( primaryKey #id `as` #pk_users ) >>>- createTable #emails- ( serial `as` #id :*- (int & notNullable) `as` #user_id :*- (text & nullable) `as` #email )- ( primaryKey #id `as` #pk_emails :*- foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )-in printSQL setup-:}-CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));-CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);--A `foreignKey` can even be a table self-reference.-->>> :{-type Schema =- '[ "employees" ::: 'Table (- '[ "employees_pk" ::: 'PrimaryKey '["id"]- , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- , "employer_id" ::: 'NoDef :=> 'Null 'PGint4- ])- ]-:}-->>> :{-let- setup :: Definition (Public '[]) (Public Schema)- setup =- createTable #employees- ( serial `as` #id :*- (text & notNullable) `as` #name :*- (integer & nullable) `as` #employer_id )- ( primaryKey #id `as` #employees_pk :*- foreignKey #employer_id #employees #id- OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )-in printSQL setup-:}-CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);--}-foreignKey- :: (ForeignKeyed schemas sch schema child parent- table reftable- columns refcolumns- constraints cols- reftys tys )- => NP Alias columns- -- ^ column or columns in the table- -> Alias parent- -- ^ reference table- -> NP Alias refcolumns- -- ^ reference column or columns in the reference table- -> OnDeleteClause- -- ^ what to do when reference is deleted- -> OnUpdateClause- -- ^ what to do when reference is updated- -> TableConstraintExpression sch child schemas- ('ForeignKey columns parent refcolumns)-foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $- "FOREIGN KEY" <+> parenthesized (renderSQL keys)- <+> "REFERENCES" <+> renderSQL parent- <+> parenthesized (renderSQL refs)- <+> renderSQL ondel- <+> renderSQL onupd---- | A constraint synonym between types involved in a foreign key constraint.-type ForeignKeyed schemas- sch- schema- child parent- table reftable- columns refcolumns- constraints cols- reftys tys =- ( Has sch schemas schema- , Has child schema ('Table table)- , Has parent schema ('Table reftable)- , HasAll columns (TableToColumns table) tys- , reftable ~ (constraints :=> cols)- , HasAll refcolumns cols reftys- , SOP.AllZip SamePGType tys reftys- , Uniquely refcolumns constraints )---- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.-data OnDeleteClause- = OnDeleteNoAction- -- ^ if any referencing rows still exist when the constraint is checked,- -- an error is raised- | OnDeleteRestrict -- ^ prevents deletion of a referenced row- | OnDeleteCascade- -- ^ specifies that when a referenced row is deleted,- -- row(s) referencing it should be automatically deleted as well- deriving (GHC.Generic,Show,Eq,Ord)-instance NFData OnDeleteClause--- | Render `OnDeleteClause`.-instance RenderSQL OnDeleteClause where- renderSQL = \case- OnDeleteNoAction -> "ON DELETE NO ACTION"- OnDeleteRestrict -> "ON DELETE RESTRICT"- OnDeleteCascade -> "ON DELETE CASCADE"---- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked--- when a referenced column is changed (updated).-data OnUpdateClause- = OnUpdateNoAction- -- ^ if any referencing rows has not changed when the constraint is checked,- -- an error is raised- | OnUpdateRestrict -- ^ prevents update of a referenced row- | OnUpdateCascade- -- ^ the updated values of the referenced column(s) should be copied- -- into the referencing row(s)- deriving (GHC.Generic,Show,Eq,Ord)-instance NFData OnUpdateClause---- | Render `OnUpdateClause`.-instance RenderSQL OnUpdateClause where- renderSQL = \case- OnUpdateNoAction -> "ON UPDATE NO ACTION"- OnUpdateRestrict -> "ON UPDATE RESTRICT"- OnUpdateCascade -> "ON UPDATE CASCADE"--{------------------------------------------DROP statements------------------------------------------}---- | >>> :{--- let--- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]--- definition = dropSchema #muh_schema--- :}------ >>> printSQL definition--- DROP SCHEMA "muh_schema";-dropSchema- :: Has sch schemas schema- => Alias sch- -> Definition schemas (Drop sch schemas)-dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"---- | `dropTable` removes a table from the schema.------ >>> :{--- let--- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])--- definition = dropTable #muh_table--- :}------ >>> printSQL definition--- DROP TABLE "muh_table";-dropTable- :: ( Has sch schemas schema- , Has tab schema ('Table table))- => QualifiedAlias sch tab -- ^ table to remove- -> Definition schemas (Alter sch (Drop tab schema) schemas)-dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"--{------------------------------------------ALTER statements------------------------------------------}---- | `alterTable` changes the definition of a table from the schema.-alterTable- :: (Has sch schemas schema, Has tab schema ('Table table0))- => QualifiedAlias sch tab -- ^ table to alter- -> AlterTable sch tab schemas table1 -- ^ alteration to perform- -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)-alterTable tab alteration = UnsafeDefinition $- "ALTER TABLE"- <+> renderSQL tab- <+> renderAlterTable alteration- <> ";"---- | `alterTableRename` changes the name of a table from the schema.------ >>> printSQL $ 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" <+> renderSQL table0- <+> "RENAME TO" <+> renderSQL table1 <> ";"---- | An `AlterTable` describes the alteration to perform on the columns--- of a table.-newtype AlterTable- (sch :: Symbol)- (tab :: Symbol)- (schemas :: SchemasType)- (table :: TableType) =- UnsafeAlterTable {renderAlterTable :: ByteString}- deriving (GHC.Generic,Show,Eq,Ord,NFData)---- | An `addConstraint` adds a table constraint.------ >>> :{--- let--- definition :: Definition--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))--- in printSQL definition--- :}--- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));-addConstraint- :: ( KnownSymbol alias- , Has sch schemas schema- , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns)- , table1 ~ (Create alias constraint constraints :=> columns) )- => Alias alias- -> TableConstraintExpression sch tab schemas constraint- -- ^ constraint to add- -> AlterTable sch tab schemas table1-addConstraint alias constraint = UnsafeAlterTable $- "ADD" <+> "CONSTRAINT" <+> renderSQL alias- <+> renderSQL constraint---- | A `dropConstraint` drops a table constraint.------ >>> :{--- let--- definition :: Definition--- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- definition = alterTable #tab (dropConstraint #positive)--- in printSQL definition--- :}--- ALTER TABLE "tab" DROP CONSTRAINT "positive";-dropConstraint- :: ( KnownSymbol constraint- , Has sch schemas schema- , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns)- , table1 ~ (Drop constraint constraints :=> columns) )- => Alias constraint- -- ^ constraint to drop- -> AlterTable sch tab schemas table1-dropConstraint constraint = UnsafeAlterTable $- "DROP" <+> "CONSTRAINT" <+> renderSQL constraint---- | An `AddColumn` is either @NULL@ or has @DEFAULT@.-class AddColumn ty where- -- | `addColumn` adds a new column, initially filled with whatever- -- default value is given or with @NULL@.- --- -- >>> :{- -- let- -- definition :: Definition- -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]- -- '["public" ::: '["tab" ::: 'Table ('[] :=>- -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4- -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]- -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))- -- in printSQL definition- -- :}- -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';- --- -- >>> :{- -- let- -- definition :: Definition- -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]- -- '["public" ::: '["tab" ::: 'Table ('[] :=>- -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4- -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]- -- definition = alterTable #tab (addColumn #col2 (text & nullable))- -- in printSQL definition- -- :}- -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;- addColumn- :: ( KnownSymbol column- , Has sch schemas schema- , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns) )- => Alias column -- ^ column to add- -> ColumnTypeExpression schemas ty -- ^ type of the new column- -> AlterTable sch tab schemas (constraints :=> Create column ty columns)- addColumn column ty = UnsafeAlterTable $- "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty-instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)-instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null 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--- '["public" ::: '["tab" ::: 'Table ('[] :=>--- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4--- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]--- definition = alterTable #tab (dropColumn #col2)--- in printSQL definition--- :}--- ALTER TABLE "tab" DROP COLUMN "col2";-dropColumn- :: ( KnownSymbol column- , Has sch schemas schema- , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns)- , table1 ~ (constraints :=> Drop column columns) )- => Alias column -- ^ column to remove- -> AlterTable sch tab schemas table1-dropColumn column = UnsafeAlterTable $- "DROP COLUMN" <+> renderSQL column---- | A `renameColumn` renames a column.------ >>> :{--- let--- definition :: Definition--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]--- definition = alterTable #tab (renameColumn #foo #bar)--- in printSQL definition--- :}--- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";-renameColumn- :: ( KnownSymbol column0- , KnownSymbol column1- , Has sch schemas schema- , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns)- , table1 ~ (constraints :=> Rename column0 column1 columns) )- => Alias column0 -- ^ column to rename- -> Alias column1 -- ^ what to rename the column- -> AlterTable sch tab schemas table1-renameColumn column0 column1 = UnsafeAlterTable $- "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1---- | An `alterColumn` alters a single column.-alterColumn- :: ( KnownSymbol column- , Has sch schemas schema- , Has tab schema ('Table table0)- , table0 ~ (constraints :=> columns)- , Has column columns ty0- , table1 ~ (constraints :=> Alter column ty1 columns))- => Alias column -- ^ column to alter- -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform- -> AlterTable sch tab schemas table1-alterColumn column alteration = UnsafeAlterTable $- "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration---- | An `AlterColumn` describes the alteration to perform on a single column.-newtype AlterColumn (schemas :: SchemasType) (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 insert and update commands.------ >>> :{--- let--- definition :: Definition--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]--- definition = alterTable #tab (alterColumn #col (setDefault 5))--- in printSQL definition--- :}--- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;-setDefault- :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set- -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)-setDefault expression = UnsafeAlterColumn $- "SET DEFAULT" <+> renderExpression expression---- | A `dropDefault` removes any default value for a column.------ >>> :{--- let--- definition :: Definition--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]--- definition = alterTable #tab (alterColumn #col dropDefault)--- in printSQL definition--- :}--- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;-dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> 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--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- definition = alterTable #tab (alterColumn #col setNotNull)--- in printSQL definition--- :}--- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;-setNotNull- :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)-setNotNull = UnsafeAlterColumn $ "SET NOT NULL"---- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.------ >>> :{--- let--- definition :: Definition--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]--- definition = alterTable #tab (alterColumn #col dropNotNull)--- in printSQL definition--- :}--- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;-dropNotNull- :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> '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--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]--- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]--- definition =--- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))--- in printSQL definition--- :}--- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;-alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty-alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty--{- | Create a view.->>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]->>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]->>> :{-let- definition :: Definition- '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]- '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]- definition =- createView #bc (select_ (#b :* #c) (from (table #abc)))-in printSQL definition-:}-CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";--}-createView- :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)- => QualifiedAlias sch vw -- ^ the name of the view to add- -> Query '[] '[] schemas '[] view -- ^ query- -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)-createView alias query = UnsafeDefinition $- "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"- <+> renderQuery query <> ";"---- | Drop a view.------ >>> :{--- let--- definition :: Definition--- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])--- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]--- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]--- definition = dropView #bc--- in printSQL definition--- :}--- DROP VIEW "bc";-dropView- :: (Has sch schemas schema, Has vw schema ('View view))- => QualifiedAlias sch vw -- ^ view to remove- -> Definition schemas (Alter sch (Drop vw schema) schemas)-dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"---- | Enumerated types are created using the `createTypeEnum` command, for example------ >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])--- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');-createTypeEnum- :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)- => QualifiedAlias sch enum- -- ^ name of the user defined enumerated type- -> NP PGlabel labels- -- ^ labels of the enumerated type- -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)-createTypeEnum enum labels = UnsafeDefinition $- "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>- parenthesized (renderSQL labels) <> ";"---- | Enumerated types can also be generated from a Haskell type, for example------ >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic--- >>> instance SOP.Generic Schwarma--- >>> instance SOP.HasDatatypeInfo Schwarma--- >>> :{--- let--- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]--- createSchwarma = createTypeEnumFrom @Schwarma #schwarma--- in--- printSQL createSchwarma--- :}--- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');-createTypeEnumFrom- :: forall hask sch enum schemas schema.- ( SOP.Generic hask- , SOP.All KnownSymbol (LabelsPG hask)- , KnownSymbol enum- , Has sch schemas schema )- => QualifiedAlias sch enum- -- ^ name of the user defined enumerated type- -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)-createTypeEnumFrom enum = createTypeEnum enum- (SOP.hpure label :: NP PGlabel (LabelsPG hask))--{- | `createTypeComposite` creates a composite type. The composite type is-specified by a list of attribute names and data types.-->>> :{-type PGcomplex = 'PGcomposite- '[ "real" ::: 'NotNull 'PGfloat8- , "imaginary" ::: 'NotNull 'PGfloat8 ]-:}-->>> :{-let- setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]- setup = createTypeComposite #complex- (float8 `as` #real :* float8 `as` #imaginary)-in printSQL setup-:}-CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);--}-createTypeComposite- :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)- => QualifiedAlias sch ty- -- ^ name of the user defined composite type- -> NP (Aliased (TypeExpression schemas)) fields- -- ^ list of attribute names and data types- -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)-createTypeComposite ty fields = UnsafeDefinition $- "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized- (renderCommaSeparated renderField fields) <> ";"- where- renderField :: Aliased (TypeExpression schemas) x -> ByteString- renderField (typ `As` alias) =- renderSQL alias <+> renderSQL typ---- | Composite types can also be generated from a Haskell type, for example------ >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic--- >>> instance SOP.Generic Complex--- >>> instance SOP.HasDatatypeInfo Complex--- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]--- >>> :{--- let--- createComplex :: Definition (Public '[]) (Public Schema)--- createComplex = createTypeCompositeFrom @Complex #complex--- in--- printSQL createComplex--- :}--- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);-createTypeCompositeFrom- :: forall hask sch ty schemas schema.- ( SOP.All (FieldTyped schemas) (RowPG hask)- , KnownSymbol ty- , Has sch schemas schema )- => QualifiedAlias sch ty- -- ^ name of the user defined composite type- -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)-createTypeCompositeFrom ty = createTypeComposite ty- (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype- :: NP (Aliased (TypeExpression schemas)) (RowPG hask))--{-|-`createDomain` creates a new domain. A domain is essentially a data type-with constraints (restrictions on the allowed set of values).--Domains are useful for abstracting common constraints on fields-into a single location for maintenance. For example, several tables might-contain email address columns, all requiring the same `check` constraint-to verify the address syntax. Define a domain rather than setting up-each table's constraint individually.-->>> :{-let- createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])- createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))-in printSQL createPositive-:}-CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));--}-createDomain- :: (Has sch schemas schema, KnownSymbol dom)- => QualifiedAlias sch dom- -> (forall nullity. TypeExpression schemas (nullity ty))- -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])- -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)-createDomain dom ty condition =- UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom- <+> "AS" <+> renderTypeExpression ty- <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"---- | Lift `PGTyped` to a field-class FieldTyped schemas ty where- fieldtype :: Aliased (TypeExpression schemas) ty-instance (KnownSymbol alias, PGTyped schemas ty)- => FieldTyped schemas (alias ::: ty) where- fieldtype = pgtype `As` Alias---- | Drop a type.------ >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic--- >>> instance SOP.Generic Schwarma--- >>> instance SOP.HasDatatypeInfo Schwarma--- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))--- DROP TYPE "schwarma";-dropType- :: (Has sch schemas schema, Has td schema ('Typedef ty))- => QualifiedAlias sch td- -- ^ name of the user defined type- -> Definition schemas (Alter sch (Drop td schema) schemas)-dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"---- | `ColumnTypeExpression`s are used in `createTable` commands.-newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)- = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (ColumnTypeExpression schemas ty) where- renderSQL = renderColumnTypeExpression---- | used in `createTable` commands as a column constraint to note that--- @NULL@ may be present in a column-nullable- :: TypeExpression schemas (nullity ty)- -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)-nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"---- | used in `createTable` commands as a column constraint to ensure--- @NULL@ is not present in a column-notNullable- :: TypeExpression schemas (nullity ty)- -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)-notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"---- | used in `createTable` commands as a column constraint to give a default-default_- :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty- -> ColumnTypeExpression schemas ('NoDef :=> ty)- -> ColumnTypeExpression schemas ('Def :=> ty)-default_ x ty = UnsafeColumnTypeExpression $- renderSQL ty <+> "DEFAULT" <+> renderExpression x---- | not a true type, but merely a notational convenience for creating--- unique identifier columns with type `PGint2`-serial2, smallserial- :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)-serial2 = UnsafeColumnTypeExpression "serial2"-smallserial = UnsafeColumnTypeExpression "smallserial"--- | not a true type, but merely a notational convenience for creating--- unique identifier columns with type `PGint4`-serial4, serial- :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)-serial4 = UnsafeColumnTypeExpression "serial4"-serial = UnsafeColumnTypeExpression "serial"--- | not a true type, but merely a notational convenience for creating--- unique identifier columns with type `PGint8`-serial8, bigserial- :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)-serial8 = UnsafeColumnTypeExpression "serial8"-bigserial = UnsafeColumnTypeExpression "bigserial"+Description: data definition language+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++data definition language+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Definition+ ( -- * Definition+ Definition (..)+ , (>>>)+ , manipulation_+ ) where++import Control.Category+import Control.DeepSeq+import Data.ByteString+import Data.Monoid+import Prelude hiding ((.), id)++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+statements+-----------------------------------------}++-- | A `Definition` is a statement that changes the schemas of the+-- database, like a `Squeal.PostgreSQL.Definition.Table.createTable`,+-- `Squeal.PostgreSQL.Definition.Table.dropTable`,+-- or `Squeal.PostgreSQL.Definition.Table.alterTable` command.+-- `Definition`s may be composed using the `>>>` operator.+newtype Definition+ (db0 :: SchemasType)+ (db1 :: SchemasType)+ = UnsafeDefinition { renderDefinition :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++instance RenderSQL (Definition db0 db1) where+ renderSQL = renderDefinition++instance Category Definition where+ id = UnsafeDefinition ";"+ ddl1 . ddl0 = UnsafeDefinition $+ renderSQL ddl0 <> "\n" <> renderSQL ddl1++instance db0 ~ db1 => Semigroup (Definition db0 db1) where (<>) = (>>>)+instance db0 ~ db1 => Monoid (Definition db0 db1) where mempty = id++-- | A `Manipulation` without input or output can be run as a statement+-- along with other `Definition`s, by embedding it using `manipulation_`.+manipulation_+ :: Manipulation '[] db '[] '[]+ -- ^ no input or output+ -> Definition db db+manipulation_ = UnsafeDefinition . (<> ";") . renderSQL
+ src/Squeal/PostgreSQL/Definition/Comment.hs view
@@ -0,0 +1,166 @@+{- |+Module: Squeal.PostgreSQL.Definition.Constraint+Description: comments+Copyright: (c) Eitan Chatav, 2020+Maintainer: eitan@morphism.tech+Stability: experimental+ +comments+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+ #-}++module Squeal.PostgreSQL.Definition.Comment+ ( commentOnTable+ , commentOnType+ , commentOnView+ , commentOnFunction+ , commentOnIndex+ , commentOnColumn+ , commentOnSchema+ ) where++import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema+import GHC.TypeLits (KnownSymbol)+import Data.Text (Text)++{-----------------------------------------+COMMENT statements+-----------------------------------------}++{- |+When a user views a table in the database (i.e. with \d+ <table>), it is useful+to be able to read a description of the table.+-}+commentOnTable+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , Has sch db schema+ , Has tab schema ('Table table)+ )+ => QualifiedAlias sch tab -- ^ table+ -> Text -- ^ comment+ -> Definition db db+commentOnTable alias comm = UnsafeDefinition $+ "COMMENT ON TABLE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a type in the database (i.e with \dT <type>), it is useful to+be able to read a description of the type.+-}+commentOnType+ :: ( KnownSymbol sch+ , KnownSymbol typ+ , Has sch db schema+ , Has typ schema ('Typedef type_)+ )+ => QualifiedAlias sch typ -- ^ type+ -> Text -- ^ comment+ -> Definition db db+commentOnType alias comm = UnsafeDefinition $+ "COMMENT ON TYPE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a view in the database (i.e. with \dv <view>), it is useful+to be able to read a description of the view.+-}+commentOnView+ :: ( KnownSymbol sch+ , KnownSymbol vie+ , Has sch db schema+ , Has vie schema ('View view)+ )+ => QualifiedAlias sch vie -- ^ view+ -> Text -- ^ comment+ -> Definition db db+commentOnView alias comm = UnsafeDefinition $+ "COMMENT ON VIEW" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views an index in the database (i.e. with \di+ <index>), it is+useful to be able to read a description of the index.+-}+commentOnIndex+ :: ( KnownSymbol sch+ , KnownSymbol ind+ , Has sch db schema+ , Has ind schema ('Index index)+ )+ => QualifiedAlias sch ind -- ^ index+ -> Text -- ^ comment+ -> Definition db db+commentOnIndex alias comm = UnsafeDefinition $+ "COMMENT ON INDEX" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a function in the database (i.e. with \df+ <function>), it is+useful to be able to read a description of the function.+-}+commentOnFunction+ :: ( KnownSymbol sch+ , KnownSymbol fun+ , Has sch db schema+ , Has fun schema ('Function function)+ )+ => QualifiedAlias sch fun -- ^ function+ -> Text -- ^ comment+ -> Definition db db+commentOnFunction alias comm = UnsafeDefinition $+ "COMMENT ON FUNCTION" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"++{- |+When a user views a table in the database (i.e. with \d+ <table>), it is useful+to be able to view descriptions of the columns in that table.+-}+commentOnColumn+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , KnownSymbol col+ , Has sch db schema+ , Has tab schema ('Table '(cons, cols))+ , Has col cols '(def, nulltyp)+ )+ => QualifiedAlias sch tab -- ^ table+ -> Alias col -- ^ column+ -> Text -- ^ comment+ -> Definition db db+commentOnColumn table col comm = UnsafeDefinition $+ "COMMENT ON COLUMN" <+> renderSQL table <> "." <> renderSQL col <+> "IS"+ <+> singleQuotedText comm <> ";"++{- |+When a user views a schema in the database (i.e. with \dn+ <schema>), it is+useful to be able to read a description.+-}+commentOnSchema+ :: ( KnownSymbol sch+ , Has sch db schema+ )+ => Alias sch -- ^ schema+ -> Text -- ^ comment+ -> Definition db db+commentOnSchema schema comm = UnsafeDefinition $+ "COMMENT ON SCHEMA" <+> renderSQL schema <> "IS" <+> singleQuotedText comm <> ";"
+ src/Squeal/PostgreSQL/Definition/Constraint.hs view
@@ -0,0 +1,352 @@+{-|+Module: Squeal.PostgreSQL.Definition.Constraint+Description: constraint expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++constraint expressions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Constraint+ ( -- * Table Constraints+ TableConstraintExpression (..)+ , check+ , unique+ , primaryKey+ -- ** Foreign Keys+ , foreignKey+ , ForeignKeyed+ , OnDeleteClause (..)+ , OnUpdateClause (..)+ , ReferentialAction (..)+ ) where++import Control.DeepSeq+import Data.ByteString+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | 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 TableConstraintExpression+ (sch :: Symbol)+ (tab :: Symbol)+ (db :: SchemasType)+ (constraint :: TableConstraint)+ = UnsafeTableConstraintExpression+ { renderTableConstraintExpression :: ByteString }+ deriving (GHC.Generic,Show,Eq,Ord,NFData)+instance RenderSQL+ (TableConstraintExpression sch tab db constraint) where+ renderSQL = renderTableConstraintExpression++{-| A `check` constraint is the most generic `TableConstraint` type.+It allows you to specify that the value in a certain column must satisfy+a Boolean (truth-value) expression.++>>> :{+type Schema = '[+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,+ "b" ::: 'NoDef :=> 'NotNull 'PGint4+ ])]+:}++>>> :{+let+ definition :: Definition (Public '[]) (Public Schema)+ definition = createTable #tab+ ( (int & notNullable) `as` #a :*+ (int & notNullable) `as` #b )+ ( check (#a :* #b) (#a .> #b) `as` #inequality )+:}++>>> printSQL definition+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));+-}+check+ :: ( Has sch db schema+ , Has tab schema ('Table table)+ , HasAll aliases (TableToRow table) subcolumns )+ => NP Alias aliases+ -- ^ specify the subcolumns which are getting checked+ -> (forall t. Condition 'Ungrouped '[] '[] db '[] '[t ::: subcolumns])+ -- ^ a closed `Condition` on those subcolumns+ -> TableConstraintExpression sch tab db ('Check aliases)+check _cols condition = UnsafeTableConstraintExpression $+ "CHECK" <+> parenthesized (renderSQL condition)++{-| A `unique` constraint ensure that the data contained in a column,+or a group of columns, is unique among all the rows in the table.++>>> :{+type Schema = '[+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[+ "a" ::: 'NoDef :=> 'Null 'PGint4,+ "b" ::: 'NoDef :=> 'Null 'PGint4+ ])]+:}++>>> :{+let+ definition :: Definition (Public '[]) (Public Schema)+ definition = createTable #tab+ ( (int & nullable) `as` #a :*+ (int & nullable) `as` #b )+ ( unique (#a :* #b) `as` #uq_a_b )+:}++>>> printSQL definition+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));+-}+unique+ :: ( Has sch db schema+ , Has tab schema ('Table table)+ , HasAll aliases (TableToRow table) subcolumns )+ => NP Alias aliases+ -- ^ specify subcolumns which together are unique for each row+ -> TableConstraintExpression sch tab db ('Unique aliases)+unique columns = UnsafeTableConstraintExpression $+ "UNIQUE" <+> parenthesized (renderSQL columns)++{-| A `primaryKey` constraint indicates that a column, or group of columns,+can be used as a unique identifier for rows in the table.+This requires that the values be both unique and not null.++>>> :{+type Schema = '[+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[+ "id" ::: 'Def :=> 'NotNull 'PGint4,+ "name" ::: 'NoDef :=> 'NotNull 'PGtext+ ])]+:}++>>> :{+let+ definition :: Definition (Public '[]) (Public Schema)+ definition = createTable #tab+ ( serial `as` #id :*+ (text & notNullable) `as` #name )+ ( primaryKey #id `as` #pk_id )+:}++>>> printSQL definition+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));+-}+primaryKey+ :: ( Has sch db schema+ , Has tab schema ('Table table)+ , HasAll aliases (TableToColumns table) subcolumns+ , AllNotNull subcolumns )+ => NP Alias aliases+ -- ^ specify the subcolumns which together form a primary key.+ -> TableConstraintExpression sch tab db ('PrimaryKey aliases)+primaryKey columns = UnsafeTableConstraintExpression $+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)++{-| A `foreignKey` specifies that the values in a column+(or a group of columns) must match the values appearing in some row of+another table. We say this maintains the referential integrity+between two related tables.++>>> :{+type Schema =+ '[ "users" ::: 'Table (+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ ])+ , "emails" ::: 'Table (+ '[ "pk_emails" ::: 'PrimaryKey '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"]+ ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "email" ::: 'NoDef :=> 'Null 'PGtext+ ])+ ]+:}++>>> :{+let+ setup :: Definition (Public '[]) (Public Schema)+ setup =+ createTable #users+ ( serial `as` #id :*+ (text & notNullable) `as` #name )+ ( primaryKey #id `as` #pk_users ) >>>+ createTable #emails+ ( serial `as` #id :*+ (int & notNullable) `as` #user_id :*+ (text & nullable) `as` #email )+ ( primaryKey #id `as` #pk_emails :*+ foreignKey #user_id #users #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id )+in printSQL setup+:}+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);++A `foreignKey` can even be a table self-reference.++>>> :{+type Schema =+ '[ "employees" ::: 'Table (+ '[ "employees_pk" ::: 'PrimaryKey '["id"]+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "public" "employees" '["id"]+ ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4+ ])+ ]+:}++>>> :{+let+ setup :: Definition (Public '[]) (Public Schema)+ setup =+ createTable #employees+ ( serial `as` #id :*+ (text & notNullable) `as` #name :*+ (integer & nullable) `as` #employer_id )+ ( primaryKey #id `as` #employees_pk :*+ foreignKey #employer_id #employees #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #employees_employer_fk )+in printSQL setup+:}+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);+-}+foreignKey+ :: (ForeignKeyed db + sch0 sch1+ schema0 schema1 + child parent+ table reftable+ columns refcolumns+ constraints cols+ reftys tys )+ => NP Alias columns+ -- ^ column or columns in the table+ -> QualifiedAlias sch0 parent+ -- ^ reference table+ -> NP Alias refcolumns+ -- ^ reference column or columns in the reference table+ -> OnDeleteClause+ -- ^ what to do when reference is deleted+ -> OnUpdateClause+ -- ^ what to do when reference is updated+ -> TableConstraintExpression sch1 child db+ ('ForeignKey columns sch0 parent refcolumns)+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)+ <+> "REFERENCES" <+> renderSQL parent+ <+> parenthesized (renderSQL refs)+ <+> renderSQL ondel+ <+> renderSQL onupd++-- | A constraint synonym between types involved in a foreign key constraint.+type ForeignKeyed db+ sch0 sch1+ schema0 schema1+ child parent+ table reftable+ columns refcolumns+ constraints cols+ reftys tys =+ ( Has sch0 db schema0+ , Has sch1 db schema1+ , Has parent schema0 ('Table reftable)+ , Has child schema1 ('Table table)+ , HasAll columns (TableToColumns table) tys+ , reftable ~ (constraints :=> cols)+ , HasAll refcolumns cols reftys+ , SOP.AllZip SamePGType tys reftys+ , Uniquely refcolumns constraints )++-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.+newtype OnDeleteClause = OnDelete ReferentialAction+ deriving (GHC.Generic,Show,Eq,Ord)+instance NFData OnDeleteClause+instance RenderSQL OnDeleteClause where+ renderSQL (OnDelete action) = "ON DELETE" <+> renderSQL action++-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked+-- when a referenced column is changed (updated).+newtype OnUpdateClause = OnUpdate ReferentialAction+ deriving (GHC.Generic,Show,Eq,Ord)+instance NFData OnUpdateClause+instance RenderSQL OnUpdateClause where+ renderSQL (OnUpdate action) = "ON UPDATE" <+> renderSQL action++{- | When the data in the referenced columns is changed,+certain actions are performed on the data in this table's columns.-}+data ReferentialAction+ = NoAction+ {- ^ Produce an error indicating that the deletion or update+ would create a foreign key constraint violation.+ If the constraint is deferred, this error will be produced+ at constraint check time if there still exist any referencing rows.-}+ | Restrict+ {- ^ Produce an error indicating that the deletion or update+ would create a foreign key constraint violation.+ This is the same as `NoAction` except that the check is not deferrable.-}+ | Cascade+ {- ^ Delete any rows referencing the deleted row,+ or update the value of the referencing column+ to the new value of the referenced column, respectively.-}+ | SetNull {- ^ Set the referencing column(s) to null.-}+ | SetDefault {- ^ Set the referencing column(s) to their default values.-}+ deriving (GHC.Generic,Show,Eq,Ord)+instance NFData ReferentialAction+instance RenderSQL ReferentialAction where+ renderSQL = \case+ NoAction -> "NO ACTION"+ Restrict -> "RESTRICT"+ Cascade -> "CASCADE"+ SetNull -> "SET NULL"+ SetDefault -> "SET DEFAULT"
+ src/Squeal/PostgreSQL/Definition/Function.hs view
@@ -0,0 +1,250 @@+{-|+Module: Squeal.PostgreSQL.Definition.Function+Description: create and drop functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop functions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Function+ ( -- * Create+ createFunction+ , createOrReplaceFunction+ , createSetFunction+ , createOrReplaceSetFunction+ -- * Drop+ , dropFunction+ , dropFunctionIfExists+ -- * Function Definition+ , FunctionDefinition(..)+ , languageSqlExpr+ , languageSqlQuery+ ) where++import Control.DeepSeq+import Data.ByteString+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Query.Values+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | Create a function.++>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4))+>>> :{+let+ definition :: Definition (Public '[]) (Public '["fn" ::: Fn])+ definition = createFunction #fn (int4 *: int4) int4 $+ languageSqlExpr (param @1 * param @2 + 1)+in printSQL definition+:}+CREATE FUNCTION "fn" (int4, int4) RETURNS int4 language sql as $$ SELECT * FROM (VALUES (((($1 :: int4) * ($2 :: int4)) + (1 :: int4)))) AS t ("ret") $$;+-}+createFunction+ :: ( Has sch db schema+ , KnownSymbol fun+ , SOP.SListI args )+ => QualifiedAlias sch fun -- ^ function alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> TypeExpression db ret -- ^ return type+ -> FunctionDefinition db args ('Returns ret) -- ^ function definition+ -> Definition db (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) db)+createFunction fun args ret fundef = UnsafeDefinition $+ "CREATE" <+> "FUNCTION" <+> renderSQL fun+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"++{- | Create or replace a function.+It is not possible to change the name or argument types+or return type of a function this way.++>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4))+>>> :{+let+ definition :: Definition (Public '["fn" ::: Fn]) (Public '["fn" ::: Fn])+ definition =+ createOrReplaceFunction #fn+ (int4 *: int4) int4 $+ languageSqlExpr (param @1 @('Null 'PGint4) * param @2 @('Null 'PGint4) + 1)+in printSQL definition+:}+CREATE OR REPLACE FUNCTION "fn" (int4, int4) RETURNS int4 language sql as $$ SELECT * FROM (VALUES (((($1 :: int4) * ($2 :: int4)) + (1 :: int4)))) AS t ("ret") $$;+-}+createOrReplaceFunction+ :: ( Has sch db schema+ , KnownSymbol fun+ , SOP.SListI args )+ => QualifiedAlias sch fun -- ^ function alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> TypeExpression db ret -- ^ return type+ -> FunctionDefinition db args ('Returns ret) -- ^ function definition+ -> Definition db (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) db)+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"++-- | Use a parameterized `Expression` as a function body+languageSqlExpr+ :: Expression 'Ungrouped '[] '[] db args '[] ret+ -- ^ function body+ -> FunctionDefinition db args ('Returns ret)+languageSqlExpr expr = UnsafeFunctionDefinition $+ "language sql as"+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"++-- | Use a parametrized `Query` as a function body+languageSqlQuery+ :: Query '[] '[] db args rets+ -- ^ function body+ -> FunctionDefinition db args ('ReturnsTable rets)+languageSqlQuery qry = UnsafeFunctionDefinition $+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"++{- | Create a set function.++>>> type Tab = 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])+>>> type Fn = 'Function ('[ 'Null 'PGint4, 'Null 'PGint4] :=> 'ReturnsTable '["ret" ::: 'Null 'PGint4])+>>> :{+let+ definition :: Definition (Public '["tab" ::: Tab]) (Public '["tab" ::: Tab, "fn" ::: Fn])+ definition = createSetFunction #fn (int4 *: int4) (int4 `as` #ret) $+ languageSqlQuery (select_ ((param @1 * param @2 + #col) `as` #ret) (from (table #tab)))+in printSQL definition+:}+CREATE FUNCTION "fn" (int4, int4) RETURNS TABLE ("ret" int4) language sql as $$ SELECT ((($1 :: int4) * ($2 :: int4)) + "col") AS "ret" FROM "tab" AS "tab" $$;+-}+createSetFunction+ :: ( Has sch db schema+ , KnownSymbol fun+ , SOP.SListI args+ , SOP.SListI rets )+ => QualifiedAlias sch fun -- ^ function alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> NP (Aliased (TypeExpression db)) rets -- ^ return type+ -> FunctionDefinition db args ('ReturnsTable rets) -- ^ function definition+ -> Definition db (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) db)+createSetFunction fun args rets fundef = UnsafeDefinition $+ "CREATE" <+> "FUNCTION" <+> renderSQL fun+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> "RETURNS" <+> "TABLE"+ <+> parenthesized (renderCommaSeparated renderRet rets)+ <+> renderSQL fundef <> ";"+ where+ renderRet :: Aliased (TypeExpression s) r -> ByteString+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty++{- | Create or replace a set function.++>>> type Tab = 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])+>>> type Fn = 'Function ('[ 'Null 'PGint4, 'Null 'PGint4] :=> 'ReturnsTable '["ret" ::: 'Null 'PGint4])+>>> :{+let+ definition :: Definition (Public '["tab" ::: Tab, "fn" ::: Fn]) (Public '["tab" ::: Tab, "fn" ::: Fn])+ definition = createOrReplaceSetFunction #fn (int4 *: int4) (int4 `as` #ret) $+ languageSqlQuery (select_ ((param @1 * param @2 + #col) `as` #ret) (from (table #tab)))+in printSQL definition+:}+CREATE OR REPLACE FUNCTION "fn" (int4, int4) RETURNS TABLE ("ret" int4) language sql as $$ SELECT ((($1 :: int4) * ($2 :: int4)) + "col") AS "ret" FROM "tab" AS "tab" $$;+-}+createOrReplaceSetFunction+ :: ( Has sch db schema+ , KnownSymbol fun+ , SOP.SListI args+ , SOP.SListI rets )+ => QualifiedAlias sch fun -- ^ function alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> NP (Aliased (TypeExpression db)) rets -- ^ return type+ -> FunctionDefinition db args ('ReturnsTable rets) -- ^ function definition+ -> Definition db (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) db)+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> "RETURNS" <+> "TABLE"+ <+> parenthesized (renderCommaSeparated renderRet rets)+ <+> renderSQL fundef <> ";"+ where+ renderRet :: Aliased (TypeExpression s) r -> ByteString+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty++{- | Drop a function.++>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4))+>>> :{+let+ definition :: Definition (Public '["fn" ::: Fn]) (Public '[])+ definition = dropFunction #fn+in printSQL definition+:}+DROP FUNCTION "fn";+-}+dropFunction+ :: (Has sch db schema, KnownSymbol fun)+ => QualifiedAlias sch fun+ -- ^ function alias+ -> Definition db (Alter sch (DropSchemum fun 'Function schema) db)+dropFunction fun = UnsafeDefinition $+ "DROP FUNCTION" <+> renderSQL fun <> ";"++{- | Drop a function.++>>> type Fn = 'Function ( '[ 'Null 'PGint4, 'Null 'PGint4] :=> 'Returns ( 'Null 'PGint4))+>>> :{+let+ definition :: Definition (Public '[]) (Public '[])+ definition = dropFunctionIfExists #fn+in printSQL definition+:}+DROP FUNCTION IF EXISTS "fn";+-}+dropFunctionIfExists+ :: (Has sch db schema, KnownSymbol fun)+ => QualifiedAlias sch fun+ -- ^ function alias+ -> Definition db (Alter sch (DropSchemumIfExists fun 'Function schema) db)+dropFunctionIfExists fun = UnsafeDefinition $+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"++{- | Body of a user defined function-}+newtype FunctionDefinition db args ret = UnsafeFunctionDefinition+ { renderFunctionDefinition :: ByteString }+ deriving (Eq,Show,GHC.Generic,NFData)+instance RenderSQL (FunctionDefinition db args ret) where+ renderSQL = renderFunctionDefinition
+ src/Squeal/PostgreSQL/Definition/Index.hs view
@@ -0,0 +1,187 @@+{-|+Module: Squeal.PostgreSQL.Definition.Index+Description: create and drop indexes+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop indexes+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Index+ ( -- * Create+ createIndex+ , createIndexIfNotExists+ -- * Drop+ , dropIndex+ , dropIndexIfExists+ -- * Index Method+ , IndexMethod (..)+ , btree+ , hash+ , gist+ , spgist+ , gin+ , brin+ ) where++import Data.ByteString+import GHC.TypeLits++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Expression.Sort+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> :set -XPolyKinds++{- | Create an index.++>>> :{+type Table = '[] :=>+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]+:}++>>> :{+let+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])+ setup =+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]+in printSQL setup+:}+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);+-}+createIndex+ :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix)+ => Alias ix -- ^ index alias+ -> QualifiedAlias sch tab -- ^ table alias+ -> IndexMethod method -- ^ index method+ -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]]+ -- ^ sorted columns+ -> Definition db (Alter sch (Create ix ('Index method) schema) db)+createIndex ix tab method cols = UnsafeDefinition $+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab+ <+> "USING" <+> renderSQL method+ <+> parenthesized (commaSeparated (renderIndex <$> cols))+ <> ";"+ where+ renderIndex = \case+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"+ AscNullsFirst expression -> parenthesized (renderSQL expression)+ <+> "ASC NULLS FIRST"+ DescNullsFirst expression -> parenthesized (renderSQL expression)+ <+> "DESC NULLS FIRST"+ AscNullsLast expression -> parenthesized (renderSQL expression)+ <+> "ASC NULLS LAST"+ DescNullsLast expression -> parenthesized (renderSQL expression)+ <+> "DESC NULLS LAST"++-- | Create an index if it doesn't exist.+createIndexIfNotExists+ :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix)+ => Alias ix -- ^ index alias+ -> QualifiedAlias sch tab -- ^ table alias+ -> IndexMethod method -- ^ index method+ -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]]+ -- ^ sorted columns+ -> Definition db (Alter sch (CreateIfNotExists ix ('Index method) schema) db)+createIndexIfNotExists ix tab method cols = UnsafeDefinition $+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab+ <+> "USING" <+> renderSQL method+ <+> parenthesized (commaSeparated (renderIndex <$> cols))+ <> ";"+ where+ renderIndex = \case+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"+ AscNullsFirst expression -> parenthesized (renderSQL expression)+ <+> "ASC NULLS FIRST"+ DescNullsFirst expression -> parenthesized (renderSQL expression)+ <+> "DESC NULLS FIRST"+ AscNullsLast expression -> parenthesized (renderSQL expression)+ <+> "ASC NULLS LAST"+ DescNullsLast expression -> parenthesized (renderSQL expression)+ <+> "DESC NULLS LAST"++{- |+PostgreSQL provides several index types:+B-tree, Hash, GiST, SP-GiST, GIN and BRIN.+Each index type uses a different algorithm+that is best suited to different types of queries.+-}+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}+ deriving stock (Eq, Ord, Show, GHC.Generic)+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod+-- | B-trees can handle equality and range queries on data+-- that can be sorted into some ordering.+btree :: IndexMethod 'Btree+btree = UnsafeIndexMethod "btree"+-- | Hash indexes can only handle simple equality comparisons.+hash :: IndexMethod 'Hash+hash = UnsafeIndexMethod "hash"+-- | GiST indexes are not a single kind of index,+-- but rather an infrastructure within which many different+-- indexing strategies can be implemented.+gist :: IndexMethod 'Gist+gist = UnsafeIndexMethod "gist"+-- | SP-GiST indexes, like GiST indexes,+-- offer an infrastructure that supports various kinds of searches.+spgist :: IndexMethod 'Spgist+spgist = UnsafeIndexMethod "spgist"+-- | GIN indexes are “inverted indexes” which are appropriate for+-- data values that contain multiple component values, such as arrays.+gin :: IndexMethod 'Gin+gin = UnsafeIndexMethod "gin"+-- | BRIN indexes (a shorthand for Block Range INdexes) store summaries+-- about the values stored in consecutive physical block ranges of a table.+brin :: IndexMethod 'Brin+brin = UnsafeIndexMethod "brin"++-- | Drop an index.+--+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))+-- DROP INDEX "ix";+dropIndex+ :: (Has sch db schema, KnownSymbol ix)+ => QualifiedAlias sch ix -- ^ index alias+ -> Definition db (Alter sch (DropSchemum ix 'Index schema) db)+dropIndex ix = UnsafeDefinition $ "DROP INDEX" <+> renderSQL ix <> ";"++-- | Drop an index if it exists.+dropIndexIfExists+ :: (Has sch db schema, KnownSymbol ix)+ => QualifiedAlias sch ix -- ^ index alias+ -> Definition db (Alter sch (DropSchemumIfExists ix 'Index schema) db)+dropIndexIfExists ix = UnsafeDefinition $+ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
+ src/Squeal/PostgreSQL/Definition/Procedure.hs view
@@ -0,0 +1,172 @@+{-|+Module: Squeal.PostgreSQL.Definition.Procedure+Description: create and drop procedures+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop procedures+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Procedure+ ( -- * Create+ createProcedure+ , createOrReplaceProcedure+ -- * Drop+ , dropProcedure+ , dropProcedureIfExists+ -- * Procedure Definition+ , ProcedureDefinition(..)+ , languageSqlManipulation+ ) where++import Control.DeepSeq+import Data.ByteString+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | Create a procedure.++>>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ]+>>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ])+>>> :{+let+ definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc])+ definition = createProcedure #proc (one int4) + . languageSqlManipulation+ $ [deleteFrom_ #things (#id .== param @1)]+in printSQL definition+:}+CREATE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$;+-}+createProcedure+ :: ( Has sch db schema+ , KnownSymbol pro+ , SOP.SListI args )+ => QualifiedAlias sch pro -- ^ procedure alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> ProcedureDefinition db args -- ^ procedure definition+ -> Definition db (Alter sch (Create pro ('Procedure args) schema) db)+createProcedure pro args prodef = UnsafeDefinition $+ "CREATE" <+> "PROCEDURE" <+> renderSQL pro+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> renderSQL prodef <> ";"++{- | Create or replace a procedure.+It is not possible to change the name or argument types+of a procedure this way.++>>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ]+>>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ])+>>> :{+let+ definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc])+ definition = createOrReplaceProcedure #proc (one int4) + . languageSqlManipulation+ $ [deleteFrom_ #things (#id .== param @1)]+in printSQL definition+:}+CREATE OR REPLACE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$;+-}+createOrReplaceProcedure+ :: ( Has sch db schema+ , KnownSymbol pro+ , SOP.SListI args )+ => QualifiedAlias sch pro -- ^ procedure alias+ -> NP (TypeExpression db) args -- ^ arguments+ -> ProcedureDefinition db args -- ^ procedure definition+ -> Definition db (Alter sch (CreateOrReplace pro ('Procedure args) schema) db)+createOrReplaceProcedure pro args prodef = UnsafeDefinition $+ "CREATE" <+> "OR" <+> "REPLACE" <+> "PROCEDURE" <+> renderSQL pro+ <+> parenthesized (renderCommaSeparated renderSQL args)+ <+> renderSQL prodef <> ";"++-- | Use a parameterized `Manipulation` as a procedure body+languageSqlManipulation+ :: [Manipulation '[] db args '[]]+ -- ^ procedure body+ -> ProcedureDefinition db args+languageSqlManipulation mnps = UnsafeProcedureDefinition $+ "language sql as" <+> "$$" <+> Prelude.foldr (<+>) "" (Prelude.map ((<> ";") . renderSQL) mnps) <> "$$"++-- | ++{- | Drop a procedure.++>>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4]+>>> :{+let+ definition :: Definition (Public '["proc" ::: Proc]) (Public '[])+ definition = dropProcedure #proc+in printSQL definition+:}+DROP PROCEDURE "proc";+-}+dropProcedure+ :: (Has sch db schema, KnownSymbol pro)+ => QualifiedAlias sch pro+ -- ^ procedure alias+ -> Definition db (Alter sch (DropSchemum pro 'Procedure schema) db)+dropProcedure pro = UnsafeDefinition $+ "DROP PROCEDURE" <+> renderSQL pro <> ";"++{- | Drop a procedure.++>>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4 ]+>>> :{+let+ definition :: Definition (Public '[]) (Public '[])+ definition = dropProcedureIfExists #proc+in printSQL definition+:}+DROP PROCEDURE IF EXISTS "proc";+-}+dropProcedureIfExists+ :: (Has sch db schema, KnownSymbol pro)+ => QualifiedAlias sch pro+ -- ^ procedure alias+ -> Definition db (Alter sch (DropSchemumIfExists pro 'Procedure schema) db)+dropProcedureIfExists pro = UnsafeDefinition $+ "DROP PROCEDURE IF EXISTS" <+> renderSQL pro <> ";"++{- | Body of a user defined procedure-}+newtype ProcedureDefinition db args = UnsafeProcedureDefinition+ { renderProcedureDefinition :: ByteString }+ deriving (Eq,Show,GHC.Generic,NFData)+instance RenderSQL (ProcedureDefinition db args) where+ renderSQL = renderProcedureDefinition
+ src/Squeal/PostgreSQL/Definition/Schema.hs view
@@ -0,0 +1,114 @@+{-|+Module: Squeal.PostgreSQL.Definition.Schema+Description: create and drop schemas+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop schemas+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Schema+ ( -- * Create+ createSchema+ , createSchemaIfNotExists+ -- * Drop+ , dropSchemaCascade+ , dropSchemaCascadeIfExists+ ) where++import GHC.TypeLits++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- |+`createSchema` enters a new schema into the current database.+The schema name must be distinct from the name of any existing schema+in the current database.++A schema is essentially a namespace: it contains named objects+(tables, data types, functions, and operators) whose names+can duplicate those of other objects existing in other schemas.+Named objects are accessed by `QualifiedAlias`es with the schema+name as a prefix.++>>> :{+let+ definition :: Definition '["public" ::: '[]] '["public" ::: '[], "my_schema" ::: '[]]+ definition = createSchema #my_schema+in printSQL definition+:}+CREATE SCHEMA "my_schema";+-}+createSchema+ :: KnownSymbol sch+ => Alias sch -- ^ schema alias+ -> Definition db (Create sch '[] db)+createSchema sch = UnsafeDefinition $+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"++{- | Create a schema if it does not yet exist.-}+createSchemaIfNotExists+ :: (KnownSymbol sch, Has sch db schema)+ => Alias sch -- ^ schema alias+ -> Definition db (CreateIfNotExists sch '[] db)+createSchemaIfNotExists sch = UnsafeDefinition $+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"+ <+> renderSQL sch <> ";"++-- | Drop a schema.+-- Automatically drop objects (tables, functions, etc.)+-- that are contained in the schema.+--+-- >>> :{+-- let+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]+-- definition = dropSchemaCascade #muh_schema+-- :}+--+-- >>> printSQL definition+-- DROP SCHEMA "muh_schema" CASCADE;+dropSchemaCascade+ :: KnownSymbol sch+ => Alias sch -- ^ schema alias+ -> Definition db (Drop sch db)+dropSchemaCascade sch = UnsafeDefinition $+ "DROP SCHEMA" <+> renderSQL sch <+> "CASCADE;"++-- | Drop a schema if it exists.+-- Automatically drop objects (tables, functions, etc.)+-- that are contained in the schema.+dropSchemaCascadeIfExists+ :: KnownSymbol sch+ => Alias sch -- ^ schema alias+ -> Definition db (DropIfExists sch db)+dropSchemaCascadeIfExists sch = UnsafeDefinition $+ "DROP SCHEMA IF EXISTS" <+> renderSQL sch <+> "CASCADE;"
+ src/Squeal/PostgreSQL/Definition/Table.hs view
@@ -0,0 +1,537 @@+{-|+Module: Squeal.PostgreSQL.Definition.Table+Description: create, drop and alter tables+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create, drop and alter tables+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Table+ ( -- * Create+ createTable+ , createTableIfNotExists+ -- * Drop+ , dropTable+ , dropTableIfExists+ -- * Alter+ , alterTable+ , alterTableIfExists+ , alterTableRename+ , alterTableIfExistsRename+ , alterTableSetSchema+ , AlterTable (..)+ -- ** Constraints+ , addConstraint+ , dropConstraint+ -- ** Columns+ , AddColumn (..)+ , dropColumn+ , renameColumn+ , alterColumn+ , AlterColumn (..)+ , setDefault+ , dropDefault+ , setNotNull+ , dropNotNull+ , alterType+ ) where++import Control.DeepSeq+import Data.ByteString+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Definition.Constraint+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | `createTable` adds a table to the schema.++>>> :set -XOverloadedLabels+>>> :{+type Table = '[] :=>+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]+:}++>>> :{+let+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])+ setup = createTable #tab+ (nullable int `as` #a :* nullable real `as` #b) Nil+in printSQL setup+:}+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);+-}+createTable+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , columns ~ (col ': cols)+ , SOP.SListI columns+ , SOP.SListI constraints+ , Has sch db0 schema0+ , db1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) db0 )+ => QualifiedAlias sch tab -- ^ the name of the table to add+ -> NP (Aliased (ColumnTypeExpression db0)) columns+ -- ^ the names and datatype of each column+ -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints+ -- ^ constraints that must hold for the table+ -> Definition db0 db1+createTable tab columns constraints = UnsafeDefinition $+ "CREATE TABLE" <+> renderCreation tab columns constraints++{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in+the `Control.Category.Category` of `Definition`s.++>>> :set -XOverloadedLabels -XTypeApplications+>>> :{+type Table = '[] :=>+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]+:}++>>> type Schemas = Public '["tab" ::: 'Table Table]++>>> :{+let+ setup :: Definition Schemas Schemas+ setup = createTableIfNotExists #tab+ (nullable int `as` #a :* nullable real `as` #b) Nil+in printSQL setup+:}+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);+-}+createTableIfNotExists+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , columns ~ (col ': cols)+ , SOP.SListI columns+ , SOP.SListI constraints+ , Has sch db0 schema0+ , db1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) db0 )+ => QualifiedAlias sch tab -- ^ the name of the table to add+ -> NP (Aliased (ColumnTypeExpression db0)) columns+ -- ^ the names and datatype of each column+ -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints+ -- ^ constraints that must hold for the table+ -> Definition db0 db1+createTableIfNotExists tab columns constraints = UnsafeDefinition $+ "CREATE TABLE IF NOT EXISTS"+ <+> renderCreation tab columns constraints++-- helper function for `createTable` and `createTableIfNotExists`+renderCreation+ :: ( KnownSymbol sch+ , KnownSymbol tab+ , SOP.SListI columns+ , SOP.SListI constraints )+ => QualifiedAlias sch tab -- ^ the name of the table to add+ -> NP (Aliased (ColumnTypeExpression db0)) columns+ -- ^ the names and datatype of each column+ -> NP (Aliased (TableConstraintExpression sch tab db1)) constraints+ -- ^ constraints that must hold for the table+ -> ByteString+renderCreation tab columns constraints = renderSQL tab+ <+> parenthesized+ ( renderCommaSeparated renderColumnDef columns+ <> ( case constraints of+ Nil -> ""+ _ -> ", " <>+ renderCommaSeparated renderConstraint constraints ) )+ <> ";"+ where+ renderColumnDef :: Aliased (ColumnTypeExpression db) x -> ByteString+ renderColumnDef (ty `As` column) =+ renderSQL column <+> renderColumnTypeExpression ty+ renderConstraint+ :: Aliased (TableConstraintExpression sch tab db) constraint+ -> ByteString+ renderConstraint (constraint `As` alias) =+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint++-- | `dropTable` removes a table from the schema.+--+-- >>> :{+-- let+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])+-- definition = dropTable #muh_table+-- :}+--+-- >>> printSQL definition+-- DROP TABLE "muh_table";+dropTable+ :: ( Has sch db schema+ , KnownSymbol tab )+ => QualifiedAlias sch tab -- ^ table to remove+ -> Definition db (Alter sch (DropSchemum tab 'Table schema) db)+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"++-- | Drop a table if it exists.+dropTableIfExists+ :: ( Has sch db schema+ , KnownSymbol tab)+ => QualifiedAlias sch tab -- ^ table to remove+ -> Definition db (Alter sch (DropSchemumIfExists tab 'Table schema) db)+dropTableIfExists tab = UnsafeDefinition $+ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"++-- | `alterTable` changes the definition of a table from the schema.+alterTable+ :: (Has sch db schema, KnownSymbol tab)+ => QualifiedAlias sch tab -- ^ table to alter+ -> AlterTable sch tab db table -- ^ alteration to perform+ -> Definition db (Alter sch (Alter tab ('Table table) schema) db)+alterTable tab alteration = UnsafeDefinition $+ "ALTER TABLE"+ <+> renderSQL tab+ <+> renderAlterTable alteration+ <> ";"++-- | `alterTable` changes the definition of a table from the schema.+alterTableIfExists+ :: (Has sch db schema, KnownSymbol tab)+ => QualifiedAlias sch tab -- ^ table to alter+ -> AlterTable sch tab db table -- ^ alteration to perform+ -> Definition db (Alter sch (AlterIfExists tab ('Table table) schema) db)+alterTableIfExists tab alteration = UnsafeDefinition $+ "ALTER TABLE IF EXISTS"+ <+> renderSQL tab+ <+> renderAlterTable alteration+ <> ";"++-- | `alterTableRename` changes the name of a table from the schema.+--+-- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ]+-- >>> :{+-- let migration :: Definition Schemas '["public" ::: '["bar" ::: 'Table ('[] :=> '[]) ] ]+-- migration = alterTableRename #foo #bar+-- in printSQL migration+-- :}+-- ALTER TABLE "foo" RENAME TO "bar";+alterTableRename+ :: ( Has sch db schema+ , KnownSymbol tab1+ , Has tab0 schema ('Table table))+ => QualifiedAlias sch tab0 -- ^ table to rename+ -> Alias tab1 -- ^ what to rename it+ -> Definition db (Alter sch (Rename tab0 tab1 schema) db )+alterTableRename tab0 tab1 = UnsafeDefinition $+ "ALTER TABLE" <+> renderSQL tab0+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"++-- | `alterTableIfExistsRename` changes the name of a table from the schema if it exists.+--+-- >>> type Schemas = '[ "public" ::: '[ "foo" ::: 'Table ('[] :=> '[]) ] ]+-- >>> :{+-- let migration :: Definition Schemas Schemas+-- migration = alterTableIfExistsRename #goo #gar+-- in printSQL migration+-- :}+-- ALTER TABLE IF EXISTS "goo" RENAME TO "gar";+alterTableIfExistsRename+ :: ( Has sch db schema+ , KnownSymbol tab0+ , KnownSymbol tab1 )+ => QualifiedAlias sch tab0 -- ^ table to rename+ -> Alias tab1 -- ^ what to rename it+ -> Definition db (Alter sch (RenameIfExists tab0 tab1 schema) db )+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"++{- | This form moves the table into another schema.++>>> type DB0 = '[ "sch0" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ], "sch1" ::: '[] ]+>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "tab" ::: 'Table ('[] :=> '[]) ] ]+>>> :{+let def :: Definition DB0 DB1+ def = alterTableSetSchema (#sch0 ! #tab) #sch1+in printSQL def+:}+ALTER TABLE "sch0"."tab" SET SCHEMA "sch1";+-}+alterTableSetSchema+ :: ( Has sch0 db schema0+ , Has tab schema0 ('Table table)+ , Has sch1 db schema1 )+ => QualifiedAlias sch0 tab -- ^ table to move+ -> Alias sch1 -- ^ where to move it+ -> Definition db (SetSchema sch0 sch1 schema0 schema1 tab 'Table table db)+alterTableSetSchema tab sch = UnsafeDefinition $+ "ALTER TABLE" <+> renderSQL tab <+> "SET SCHEMA" <+> renderSQL sch <> ";"++-- | An `AlterTable` describes the alteration to perform on the columns+-- of a table.+newtype AlterTable+ (sch :: Symbol)+ (tab :: Symbol)+ (db :: SchemasType)+ (table :: TableType) =+ UnsafeAlterTable {renderAlterTable :: ByteString}+ deriving (GHC.Generic,Show,Eq,Ord,NFData)++-- | An `addConstraint` adds a table constraint.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > (0 :: int4)));+addConstraint+ :: ( KnownSymbol alias+ , Has sch db schema+ , Has tab schema ('Table (constraints :=> columns)) )+ => Alias alias+ -> TableConstraintExpression sch tab db constraint+ -- ^ constraint to add+ -> AlterTable sch tab db (Create alias constraint constraints :=> columns)+addConstraint alias constraint = UnsafeAlterTable $+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias+ <+> renderSQL constraint++-- | A `dropConstraint` drops a table constraint.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- definition = alterTable #tab (dropConstraint #positive)+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";+dropConstraint+ :: ( KnownSymbol constraint+ , Has sch db schema+ , Has tab schema ('Table (constraints :=> columns)) )+ => Alias constraint+ -- ^ constraint to drop+ -> AlterTable sch tab db (Drop constraint constraints :=> columns)+dropConstraint constraint = UnsafeAlterTable $+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint++-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.+class AddColumn ty where+ -- | `addColumn` adds a new column, initially filled with whatever+ -- default value is given or with @NULL@.+ --+ -- >>> :{+ -- let+ -- definition :: Definition+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))+ -- in printSQL definition+ -- :}+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT (E'foo' :: text);+ --+ -- >>> :{+ -- let+ -- definition :: Definition+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))+ -- in printSQL definition+ -- :}+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;+ addColumn+ :: ( KnownSymbol column+ , Has sch db schema+ , Has tab schema ('Table (constraints :=> columns)) )+ => Alias column -- ^ column to add+ -> ColumnTypeExpression db ty -- ^ type of the new column+ -> AlterTable sch tab db (constraints :=> Create column ty columns)+ addColumn column ty = UnsafeAlterTable $+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null 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+-- '["public" ::: '["tab" ::: 'Table ('[] :=>+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]+-- definition = alterTable #tab (dropColumn #col2)+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" DROP COLUMN "col2";+dropColumn+ :: ( KnownSymbol column+ , Has sch db schema+ , Has tab schema ('Table (constraints :=> columns)) )+ => Alias column -- ^ column to remove+ -> AlterTable sch tab db (constraints :=> Drop column columns)+dropColumn column = UnsafeAlterTable $+ "DROP COLUMN" <+> renderSQL column++-- | A `renameColumn` renames a column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]+-- definition = alterTable #tab (renameColumn #foo #bar)+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";+renameColumn+ :: ( KnownSymbol column0+ , KnownSymbol column1+ , Has sch db schema+ , Has tab schema ('Table (constraints :=> columns)) )+ => Alias column0 -- ^ column to rename+ -> Alias column1 -- ^ what to rename the column+ -> AlterTable sch tab db (constraints :=> Rename column0 column1 columns)+renameColumn column0 column1 = UnsafeAlterTable $+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1++-- | An `alterColumn` alters a single column.+alterColumn+ :: ( KnownSymbol column+ , Has sch db schema+ , Has tab schema ('Table (constraints :=> columns))+ , Has column columns ty0 )+ => Alias column -- ^ column to alter+ -> AlterColumn db ty0 ty1 -- ^ alteration to perform+ -> AlterTable sch tab db (constraints :=> Alter column ty1 columns)+alterColumn column alteration = UnsafeAlterTable $+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration++-- | An `AlterColumn` describes the alteration to perform on a single column.+newtype AlterColumn (db :: SchemasType) (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 insert and update commands.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]+-- definition = alterTable #tab (alterColumn #col (setDefault 5))+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT (5 :: int4);+setDefault+ :: Expression 'Ungrouped '[] '[] db '[] '[] ty -- ^ default value to set+ -> AlterColumn db (constraint :=> ty) ('Def :=> ty)+setDefault expression = UnsafeAlterColumn $+ "SET DEFAULT" <+> renderExpression expression++-- | A `dropDefault` removes any default value for a column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]+-- definition = alterTable #tab (alterColumn #col dropDefault)+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;+dropDefault :: AlterColumn db ('Def :=> ty) ('NoDef :=> 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+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- definition = alterTable #tab (alterColumn #col setNotNull)+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;+setNotNull+ :: AlterColumn db (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"++-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.+--+-- >>> :{+-- let+-- definition :: Definition+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]+-- definition = alterTable #tab (alterColumn #col dropNotNull)+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;+dropNotNull+ :: AlterColumn db (constraint :=> 'NotNull ty) (constraint :=> '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+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]+-- definition =+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))+-- in printSQL definition+-- :}+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;+alterType :: ColumnTypeExpression db ty -> AlterColumn db ty0 ty+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
+ src/Squeal/PostgreSQL/Definition/Type.hs view
@@ -0,0 +1,292 @@+{-|+Module: Squeal.PostgreSQL.Definition.Type+Description: create and drop types+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop types+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Type+ ( -- * Create+ createTypeEnum+ , createTypeEnumFrom+ , createTypeComposite+ , createTypeCompositeFrom+ , createTypeRange+ , createDomain+ -- * Drop+ , dropType+ , dropTypeIfExists+ -- * Alter+ , alterTypeRename+ , alterTypeSetSchema+ ) where++import Data.ByteString+import Data.Monoid+import GHC.TypeLits+import Prelude hiding ((.), id)++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.PG+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> import qualified GHC.Generics as GHC+-- >>> import qualified Generics.SOP as SOP++-- | Enumerated types are created using the `createTypeEnum` command, for example+--+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');+createTypeEnum+ :: (KnownSymbol enum, Has sch db schema, SOP.All KnownSymbol labels)+ => QualifiedAlias sch enum+ -- ^ name of the user defined enumerated type+ -> NP PGlabel labels+ -- ^ labels of the enumerated type+ -> Definition db (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) db)+createTypeEnum enum labels = UnsafeDefinition $+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>+ parenthesized (renderSQL labels) <> ";"++-- | Enumerated types can also be generated from a Haskell type, for example+--+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic+-- >>> instance SOP.Generic Schwarma+-- >>> instance SOP.HasDatatypeInfo Schwarma+-- >>> :{+-- let+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma+-- in+-- printSQL createSchwarma+-- :}+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');+createTypeEnumFrom+ :: forall hask sch enum db schema.+ ( SOP.Generic hask+ , SOP.All KnownSymbol (LabelsPG hask)+ , KnownSymbol enum+ , Has sch db schema )+ => QualifiedAlias sch enum+ -- ^ name of the user defined enumerated type+ -> Definition db (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) db)+createTypeEnumFrom enum = createTypeEnum enum+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))++{- | `createTypeComposite` creates a composite type. The composite type is+specified by a list of attribute names and data types.++>>> :{+type PGcomplex = 'PGcomposite+ '[ "real" ::: 'NotNull 'PGfloat8+ , "imaginary" ::: 'NotNull 'PGfloat8 ]+:}++>>> :{+let+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]+ setup = createTypeComposite #complex+ (float8 `as` #real :* float8 `as` #imaginary)+in printSQL setup+:}+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);+-}+createTypeComposite+ :: (KnownSymbol ty, Has sch db schema, SOP.SListI fields)+ => QualifiedAlias sch ty+ -- ^ name of the user defined composite type+ -> NP (Aliased (TypeExpression db)) fields+ -- ^ list of attribute names and data types+ -> Definition db (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) db)+createTypeComposite ty fields = UnsafeDefinition $+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized+ (renderCommaSeparated renderField fields) <> ";"+ where+ renderField :: Aliased (TypeExpression db) x -> ByteString+ renderField (typ `As` alias) =+ renderSQL alias <+> renderSQL typ++-- | Composite types can also be generated from a Haskell type, for example+--+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic+-- >>> instance SOP.Generic Complex+-- >>> instance SOP.HasDatatypeInfo Complex+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]+-- >>> :{+-- let+-- createComplex :: Definition (Public '[]) (Public Schema)+-- createComplex = createTypeCompositeFrom @Complex #complex+-- in+-- printSQL createComplex+-- :}+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);+createTypeCompositeFrom+ :: forall hask sch ty db schema.+ ( SOP.All (FieldTyped db) (RowPG hask)+ , KnownSymbol ty+ , Has sch db schema )+ => QualifiedAlias sch ty+ -- ^ name of the user defined composite type+ -> Definition db (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) db)+createTypeCompositeFrom ty = createTypeComposite ty+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped db)) fieldtype+ :: NP (Aliased (TypeExpression db)) (RowPG hask))++{-|+`createDomain` creates a new domain. A domain is essentially a data type+with constraints (restrictions on the allowed set of values).++Domains are useful for abstracting common constraints on fields+into a single location for maintenance. For example, several tables might+contain email address columns, all requiring the same+`Squeal.PostgreSQL.Definition.Table.Constraint.check` constraint+to verify the address syntax. Define a domain rather than setting up+each table's constraint individually.++>>> :{+let+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])+ createPositive = createDomain #positive real (#value .> 0)+in printSQL createPositive+:}+CREATE DOMAIN "positive" AS real CHECK (("value" > (0.0 :: float4)));+-}+createDomain+ :: (Has sch db schema, KnownSymbol dom)+ => QualifiedAlias sch dom -- ^ domain alias+ -> (forall null. TypeExpression db (null ty)) -- ^ underlying type+ -> (forall tab. Condition 'Ungrouped '[] '[] db '[] '[tab ::: '["value" ::: 'Null ty]])+ -- ^ constraint on type+ -> Definition db (Alter sch (Create dom ('Typedef ty) schema) db)+createDomain dom ty condition =+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom+ <+> "AS" <+> renderTypeExpression ty+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"++{- | Range types are data types representing a range of values+of some element type (called the range's subtype).+The subtype must have a total order so that it is well-defined+whether element values are within, before, or after a range of values.++Range types are useful because they represent many element values+in a single range value, and because concepts such as overlapping ranges+can be expressed clearly.+The use of time and date ranges for scheduling purposes+is the clearest example; but price ranges,+measurement ranges from an instrument, and so forth can also be useful.++>>> :{+let+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])+ createSmallIntRange = createTypeRange #int2range int2+in printSQL createSmallIntRange+:}+CREATE TYPE "int2range" AS RANGE (subtype = int2);+-}+createTypeRange+ :: (Has sch db schema, KnownSymbol range)+ => QualifiedAlias sch range -- ^ range alias+ -> (forall null. TypeExpression db (null ty)) -- ^ underlying type+ -> Definition db (Alter sch (Create range ('Typedef ('PGrange ty)) schema) db)+createTypeRange range ty = UnsafeDefinition $+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"++-- | Drop a type.+--+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic+-- >>> instance SOP.Generic Schwarma+-- >>> instance SOP.HasDatatypeInfo Schwarma+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))+-- DROP TYPE "schwarma";+dropType+ :: (Has sch db schema, KnownSymbol td)+ => QualifiedAlias sch td+ -- ^ name of the user defined type+ -> Definition db (Alter sch (DropSchemum td 'Typedef schema) db)+dropType tydef = UnsafeDefinition $ "DROP TYPE" <+> renderSQL tydef <> ";"++-- | Drop a type if it exists.+dropTypeIfExists+ :: (Has sch db schema, KnownSymbol td)+ => QualifiedAlias sch td+ -- ^ name of the user defined type+ -> Definition db (Alter sch (DropSchemumIfExists td 'Typedef schema) db)+dropTypeIfExists tydef = UnsafeDefinition $+ "DROP TYPE IF EXISTS" <+> renderSQL tydef <> ";"++-- | `alterTypeRename` changes the name of a type from the schema.+--+-- >>> type DB = '[ "public" ::: '[ "foo" ::: 'Typedef 'PGbool ] ]+-- >>> :{+-- let def :: Definition DB '["public" ::: '["bar" ::: 'Typedef 'PGbool ] ]+-- def = alterTypeRename #foo #bar+-- in printSQL def+-- :}+-- ALTER TYPE "foo" RENAME TO "bar";+alterTypeRename+ :: ( Has sch db schema+ , KnownSymbol ty1+ , Has ty0 schema ('Typedef ty))+ => QualifiedAlias sch ty0 -- ^ type to rename+ -> Alias ty1 -- ^ what to rename it+ -> Definition db (Alter sch (Rename ty0 ty1 schema) db )+alterTypeRename ty0 ty1 = UnsafeDefinition $+ "ALTER TYPE" <+> renderSQL ty0+ <+> "RENAME TO" <+> renderSQL ty1 <> ";"++{- | This form moves the type into another schema.++>>> type DB0 = '[ "sch0" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ], "sch1" ::: '[] ]+>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "ty" ::: 'Typedef 'PGfloat8 ] ]+>>> :{+let def :: Definition DB0 DB1+ def = alterTypeSetSchema (#sch0 ! #ty) #sch1+in printSQL def+:}+ALTER TYPE "sch0"."ty" SET SCHEMA "sch1";+-}+alterTypeSetSchema+ :: ( Has sch0 db schema0+ , Has ty schema0 ('Typedef td)+ , Has sch1 db schema1 )+ => QualifiedAlias sch0 ty -- ^ type to move+ -> Alias sch1 -- ^ where to move it+ -> Definition db (SetSchema sch0 sch1 schema0 schema1 ty 'Typedef td db)+alterTypeSetSchema ty sch = UnsafeDefinition $+ "ALTER TYPE" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";"
+ src/Squeal/PostgreSQL/Definition/View.hs view
@@ -0,0 +1,180 @@+{-|+Module: Squeal.PostgreSQL.Definition.View+Description: create and drop views+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++create and drop views+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.View+ ( -- * Create+ createView+ , createOrReplaceView+ -- * Drop+ , dropView+ , dropViewIfExists+ -- * Alter+ , alterViewRename+ , alterViewSetSchema+ ) where++import GHC.TypeLits++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | Create a view.++>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]+>>> :{+let+ definition :: Definition+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]+ definition =+ createView #bc (select_ (#b :* #c) (from (table #abc)))+in printSQL definition+:}+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";+-}+createView+ :: (Has sch db schema, KnownSymbol vw)+ => QualifiedAlias sch vw -- ^ the name of the view to add+ -> Query '[] '[] db '[] view -- ^ query+ -> Definition db (Alter sch (Create vw ('View view) schema) db)+createView alias query = UnsafeDefinition $+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"+ <+> renderQuery query <> ";"++{- | Create or replace a view.++>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]+>>> :{+let+ definition :: Definition+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]+ definition =+ createOrReplaceView #bc (select_ (#b :* #c) (from (table #abc)))+in printSQL definition+:}+CREATE OR REPLACE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";+-}+createOrReplaceView+ :: (Has sch db schema, KnownSymbol vw)+ => QualifiedAlias sch vw -- ^ the name of the view to add+ -> Query '[] '[] db '[] view -- ^ query+ -> Definition db (Alter sch (CreateOrReplace vw ('View view) schema) db)+createOrReplaceView alias query = UnsafeDefinition $+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"+ <+> renderQuery query <> ";"++-- | Drop a view.+--+-- >>> :{+-- let+-- definition :: Definition+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]+-- definition = dropView #bc+-- in printSQL definition+-- :}+-- DROP VIEW "bc";+dropView+ :: (Has sch db schema, KnownSymbol vw)+ => QualifiedAlias sch vw -- ^ view to remove+ -> Definition db (Alter sch (DropSchemum vw 'View schema) db)+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"++-- | Drop a view if it exists.+--+-- >>> :{+-- let+-- definition :: Definition+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]+-- definition = dropViewIfExists #bc+-- in printSQL definition+-- :}+-- DROP VIEW IF EXISTS "bc";+dropViewIfExists+ :: (Has sch db schema, KnownSymbol vw)+ => QualifiedAlias sch vw -- ^ view to remove+ -> Definition db (Alter sch (DropIfExists vw schema) db)+dropViewIfExists vw = UnsafeDefinition $+ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"++-- | `alterViewRename` changes the name of a view from the schema.+--+-- >>> type DB = '[ "public" ::: '[ "foo" ::: 'View '[] ] ]+-- >>> :{+-- let def :: Definition DB '["public" ::: '["bar" ::: 'View '[] ] ]+-- def = alterViewRename #foo #bar+-- in printSQL def+-- :}+-- ALTER VIEW "foo" RENAME TO "bar";+alterViewRename+ :: ( Has sch db schema+ , KnownSymbol ty1+ , Has ty0 schema ('View vw))+ => QualifiedAlias sch ty0 -- ^ view to rename+ -> Alias ty1 -- ^ what to rename it+ -> Definition db (Alter sch (Rename ty0 ty1 schema) db )+alterViewRename vw0 vw1 = UnsafeDefinition $+ "ALTER VIEW" <+> renderSQL vw0+ <+> "RENAME TO" <+> renderSQL vw1 <> ";"++{- | This form moves the view into another schema.++>>> type DB0 = '[ "sch0" ::: '[ "vw" ::: 'View '[] ], "sch1" ::: '[] ]+>>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "vw" ::: 'View '[] ] ]+>>> :{+let def :: Definition DB0 DB1+ def = alterViewSetSchema (#sch0 ! #vw) #sch1+in printSQL def+:}+ALTER VIEW "sch0"."vw" SET SCHEMA "sch1";+-}+alterViewSetSchema+ :: ( Has sch0 db schema0+ , Has vw schema0 ('View view)+ , Has sch1 db schema1 )+ => QualifiedAlias sch0 vw -- ^ view to move+ -> Alias sch1 -- ^ where to move it+ -> Definition db (SetSchema sch0 sch1 schema0 schema1 vw 'View view db)+alterViewSetSchema ty sch = UnsafeDefinition $+ "ALTER VIEW" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";"
src/Squeal/PostgreSQL/Expression.hs view
@@ -1,17 +1,18 @@ {-| Module: Squeal.PostgreSQL.Expression-Description: Squeal expressions+Description: expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Squeal expressions are the atoms used to build statements.+Expressions are the atoms used to build statements. -} {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds , DeriveGeneric+ , DerivingStrategies , FlexibleContexts , FlexibleInstances , FunctionalDependencies@@ -24,7 +25,8 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances , RankNTypes@@ -34,26 +36,37 @@ ( -- * Expression Expression (..) , Expr- , (:-->)+ -- * Function+ , type (-->)+ , Fun , unsafeFunction- , unsafeUnaryOpL- , unsafeUnaryOpR+ , function+ , unsafeLeftOp+ , unsafeRightOp+ -- * Operator , Operator+ , OperatorDB , unsafeBinaryOp+ , PGSubset (..)+ , PGIntersect (..)+ -- * Multivariable Function , FunctionVar , unsafeFunctionVar- , FunctionN+ , type (--->)+ , FunN , unsafeFunctionN- , PGSubset (..)+ , functionN -- * Re-export , (&)- , K (..)- , unK ) where import Control.Category import Control.DeepSeq+import Data.Binary.Builder (toLazyByteString) import Data.ByteString (ByteString)+import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec)+import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.ByteString.Lazy (toStrict) import Data.Function ((&)) import Data.Semigroup hiding (All) import Data.String@@ -65,10 +78,10 @@ import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -80,9 +93,10 @@ {- | `Expression`s are used in a variety of contexts, such as in the target `Squeal.PostgreSQL.Query.List` of the `Squeal.PostgreSQL.Query.select` command,-as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or+as new column values in `Squeal.PostgreSQL.Manipulation.insertInto` or `Squeal.PostgreSQL.Manipulation.update`,-or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.+or in search `Squeal.PostgreSQL.Expression.Logic.Condition`s+in a number of commands. The expression syntax allows the calculation of values from primitive expression using arithmetic, logical,@@ -90,29 +104,30 @@ The type parameters of `Expression` are -* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which+* @lat :: @ `FromType`, the @from@ clauses of any lat queries in which the `Expression` is a correlated subquery expression;-* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s+* @with :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s that are in scope for the `Expression`; * @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit which columns may be referenced by alias;-* @schemas :: @ `SchemasType`, the schemas of your database that are in+* @db :: @ `SchemasType`, the schemas of your database that are in scope for the `Expression`; * @from :: @ `FromType`, the @from@ clause which the `Expression` may use to reference columns by alias;-* @ty :: @ `NullityType`, the type of the `Expression`.+* @ty :: @ `NullType`, the type of the `Expression`. -} newtype Expression- (outer :: FromType)- (commons :: FromType) (grp :: Grouping)- (schemas :: SchemasType)- (params :: [NullityType])+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType]) (from :: FromType)- (ty :: NullityType)+ (ty :: NullType) = UnsafeExpression { renderExpression :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (Expression outer commons grp schemas params from ty) where+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (Expression grp lat with db params from ty) where renderSQL = renderExpression -- | An `Expr` is a closed `Expression`.@@ -122,18 +137,21 @@ -- or alias references. It can be used as -- a simple piece of more complex `Expression`s. type Expr x- = forall outer commons grp schemas params from- . Expression outer commons grp schemas params from x+ = forall grp lat with db params from+ . Expression grp lat with db params from x -- ^ cannot reference aliases -- | A @RankNType@ for binary operators.-type Operator x1 x2 y- = forall outer commons grp schemas params from- . Expression outer commons grp schemas params from x1+type Operator x1 x2 y = forall db. OperatorDB db x1 x2 y++-- | Like `Operator` but depends on the schemas of the database+type OperatorDB db x1 x2 y+ = forall grp lat with params from+ . Expression grp lat with db params from x1 -- ^ left input- -> Expression outer commons grp schemas params from x2+ -> Expression grp lat with db params from x2 -- ^ right input- -> Expression outer commons grp schemas params from y+ -> Expression grp lat with db params from y -- ^ output -- | A @RankNType@ for functions with a single argument.@@ -141,11 +159,14 @@ -- This is a subtype of the usual Haskell function type `Prelude.->`, -- indeed a subcategory as it is closed under the usual -- `Prelude..` and `Prelude.id`.-type (:-->) x y- = forall outer commons grp schemas params from- . Expression outer commons grp schemas params from x+type (-->) x y = forall db. Fun db x y++-- | Like `-->` but depends on the schemas of the database+type Fun db x y+ = forall grp lat with params from+ . Expression grp lat with db params from x -- ^ input- -> Expression outer commons grp schemas params from y+ -> Expression grp lat with db params from y -- ^ output {- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.@@ -154,23 +175,26 @@ >>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true)) fun(TRUE, FALSE, LOCALTIME, TRUE) -}-type FunctionN xs y- = forall outer commons grp schemas params from- . NP (Expression outer commons grp schemas params from) xs+type (--->) xs y = forall db. FunN db xs y++-- | Like `--->` but depends on the schemas of the database+type FunN db xs y+ = forall grp lat with params from+ . NP (Expression grp lat with db params from) xs -- ^ inputs- -> Expression outer commons grp schemas params from y+ -> Expression grp lat with db params from y -- ^ output {- | A @RankNType@ for functions with a variable-length list of homogeneous arguments and at least 1 more argument. -} type FunctionVar x0 x1 y- = forall outer commons grp schemas params from- . [Expression outer commons grp schemas params from x0]+ = forall grp lat with db params from+ . [Expression grp lat with db params from x0] -- ^ inputs- -> Expression outer commons grp schemas params from x1+ -> Expression grp lat with db params from x1 -- ^ must have at least 1 input- -> Expression outer commons grp schemas params from y+ -> Expression grp lat with db params from y -- ^ output {- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)@@ -180,104 +204,104 @@ unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x) -instance (HasUnique tab (Join outer from) row, Has col row ty)- => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where+instance (HasUnique tab (Join from lat) row, Has col row ty)+ => IsLabel col (Expression 'Ungrouped lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col)-instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])- => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where+instance (HasUnique tab (Join from lat) row, Has col row ty, tys ~ '[ty])+ => IsLabel col (NP (Expression 'Ungrouped lat with db params from) tys) where fromLabel = fromLabel @col :* Nil-instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))+instance (HasUnique tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) => IsLabel col- (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where+ (Aliased (Expression 'Ungrouped lat with db params from) column) where fromLabel = fromLabel @col `As` Alias-instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])+instance (HasUnique tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) => IsLabel col- (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where+ (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where fromLabel = fromLabel @col :* Nil -instance (Has tab (Join outer from) row, Has col row ty)- => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where+instance (Has tab (Join from lat) row, Has col row ty)+ => IsQualified tab col (Expression 'Ungrouped lat with db params from ty) where tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col-instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])- => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where+instance (Has tab (Join from lat) row, Has col row ty, tys ~ '[ty])+ => IsQualified tab col (NP (Expression 'Ungrouped lat with db params from) tys) where tab ! col = tab ! col :* Nil-instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))+instance (Has tab (Join from lat) row, Has col row ty, column ~ (col ::: ty)) => IsQualified tab col- (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where+ (Aliased (Expression 'Ungrouped lat with db params from) column) where tab ! col = tab ! col `As` col-instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])+instance (Has tab (Join from lat) row, Has col row ty, columns ~ '[col ::: ty]) => IsQualified tab col- (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where+ (NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where tab ! col = tab ! col :* Nil instance- ( HasUnique tab (Join outer from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsLabel col- (Expression outer commons ('Grouped bys) schemas params from ty) where+ (Expression ('Grouped bys) lat with db params from ty) where fromLabel = UnsafeExpression $ renderSQL (Alias @col) instance- ( HasUnique tab (Join outer from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty] ) => IsLabel col- (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where+ (NP (Expression ('Grouped bys) lat with db params from) tys) where fromLabel = fromLabel @col :* Nil instance- ( HasUnique tab (Join outer from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty) ) => IsLabel col- (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where+ (Aliased (Expression ('Grouped bys) lat with db params from) column) where fromLabel = fromLabel @col `As` Alias instance- ( HasUnique tab (Join outer from) row+ ( HasUnique tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty] ) => IsLabel col- (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where+ (NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where fromLabel = fromLabel @col :* Nil instance- ( Has tab (Join outer from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys ) => IsQualified tab col- (Expression outer commons ('Grouped bys) schemas params from ty) where+ (Expression ('Grouped bys) lat with db params from ty) where tab ! col = UnsafeExpression $ renderSQL tab <> "." <> renderSQL col instance- ( Has tab (Join outer from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , tys ~ '[ty] ) => IsQualified tab col- (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where+ (NP (Expression ('Grouped bys) lat with db params from) tys) where tab ! col = tab ! col :* Nil instance- ( Has tab (Join outer from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , column ~ (col ::: ty) ) => IsQualified tab col- (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where+ (Aliased (Expression ('Grouped bys) lat with db params from) column) where tab ! col = tab ! col `As` col instance- ( Has tab (Join outer from) row+ ( Has tab (Join from lat) row , Has col row ty , GroupedBy tab col bys , columns ~ '[col ::: ty] ) => IsQualified tab col- (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where+ (NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where tab ! col = tab ! col :* Nil instance (KnownSymbol label, label `In` labels) => IsPGlabel label- (Expression outer commons grp schemas params from (null ('PGenum labels))) where+ (Expression grp lat with db params from (null ('PGenum labels))) where label = UnsafeExpression $ renderSQL (PGlabel @label) -- | >>> printSQL $ unsafeBinaryOp "OR" true false@@ -286,30 +310,70 @@ unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $ renderSQL x <+> op <+> renderSQL y --- | >>> printSQL $ unsafeUnaryOpL "NOT" true+-- | >>> printSQL $ unsafeLeftOp "NOT" true -- (NOT TRUE)-unsafeUnaryOpL :: ByteString -> x :--> y-unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x+unsafeLeftOp :: ByteString -> x --> y+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x --- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE" -- (TRUE IS NOT TRUE)-unsafeUnaryOpR :: ByteString -> x :--> y-unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op+unsafeRightOp :: ByteString -> x --> y+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op -- | >>> printSQL $ unsafeFunction "f" true -- f(TRUE)-unsafeFunction :: ByteString -> x :--> y+unsafeFunction :: ByteString -> x --> y unsafeFunction fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x) --- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')--- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')-unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y+{- | Call a user defined function of a single variable++>>> type Fn = '[ 'Null 'PGint4] :=> 'Returns ('NotNull 'PGnumeric)+>>> type Schema = '["fn" ::: 'Function Fn]+>>> :{+let+ fn :: Fun (Public Schema) ('Null 'PGint4) ('NotNull 'PGnumeric)+ fn = function #fn+in+ printSQL (fn 1)+:}+"fn"((1 :: int4))+-}+function+ :: (Has sch db schema, Has fun schema ('Function ('[x] :=> 'Returns y)))+ => QualifiedAlias sch fun -- ^ function name+ -> Fun db x y+function f = unsafeFunction $ renderSQL f++-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: inline 'a')+-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, (E'a' :: char(1)))+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y unsafeFunctionN fun xs = UnsafeExpression $ fun <> parenthesized (renderCommaSeparated renderSQL xs) -instance ty `In` PGNum- => Num (Expression outer commons grp schemas params from (null ty)) where+{- | Call a user defined multivariable function++>>> type Fn = '[ 'Null 'PGint4, 'Null 'PGbool] :=> 'Returns ('NotNull 'PGnumeric)+>>> type Schema = '["fn" ::: 'Function Fn]+>>> :{+let+ fn :: FunN (Public Schema) '[ 'Null 'PGint4, 'Null 'PGbool] ('NotNull 'PGnumeric)+ fn = functionN #fn+in+ printSQL (fn (1 *: true))+:}+"fn"((1 :: int4), TRUE)+-}+functionN+ :: ( Has sch db schema+ , Has fun schema ('Function (xs :=> 'Returns y))+ , SListI xs )+ => QualifiedAlias sch fun -- ^ function alias+ -> FunN db xs y+functionN f = unsafeFunctionN $ renderSQL f++instance+ Num (Expression grp lat with db params from (null 'PGint2)) where (+) = unsafeBinaryOp "+" (-) = unsafeBinaryOp "-" (*) = unsafeBinaryOp "*"@@ -317,21 +381,143 @@ signum = unsafeFunction "sign" fromInteger = UnsafeExpression- . fromString- . show+ . parenthesized+ . (<> " :: int2")+ . toStrict+ . toLazyByteString+ . int16Dec+ . fromInteger+instance+ Num (Expression grp lat with db params from (null 'PGint4)) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger+ = UnsafeExpression+ . parenthesized+ . (<> " :: int4")+ . toStrict+ . toLazyByteString+ . int32Dec+ . fromInteger+instance+ Num (Expression grp lat with db params from (null 'PGint8)) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger x =+ let+ y = fromInteger x+ in+ if y == minBound+ -- For some reason Postgres throws an error with+ -- (-9223372036854775808 :: int8)+ -- even though it's a valid lowest value for int8+ then fromInteger (x+1) - 1+ else UnsafeExpression+ . parenthesized+ . (<> " :: int8")+ . toStrict+ . toLazyByteString+ $ int64Dec y+instance+ Num (Expression grp lat with db params from (null 'PGfloat4)) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger x+ = UnsafeExpression+ . parenthesized+ . (<> " :: float4") $+ let+ y = fromInteger x+ decimal = toStrict . toLazyByteString . floatDec+ in+ if isNaN y || isInfinite y+ then singleQuotedUtf8 (decimal y)+ else decimal y+instance+ Num (Expression grp lat with db params from (null 'PGfloat8)) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger x+ = UnsafeExpression+ . parenthesized+ . (<> " :: float8") $+ let+ y = fromInteger x+ decimal = toStrict . toLazyByteString . doubleDec+ in+ if isNaN y || isInfinite y+ then singleQuotedUtf8 (decimal y)+ else decimal y+instance+ Num (Expression grp lat with db params from (null 'PGnumeric)) where+ (+) = unsafeBinaryOp "+"+ (-) = unsafeBinaryOp "-"+ (*) = unsafeBinaryOp "*"+ abs = unsafeFunction "abs"+ signum = unsafeFunction "sign"+ fromInteger+ = UnsafeExpression+ . parenthesized+ . (<> " :: numeric")+ . toStrict+ . toLazyByteString+ . scientificBuilder+ . fromInteger -instance (ty `In` PGNum, ty `In` PGFloating) => Fractional- (Expression outer commons grp schemas params from (null ty)) where+instance Fractional+ (Expression grp lat with db params from (null 'PGfloat4)) where (/) = unsafeBinaryOp "/"+ fromRational x+ = UnsafeExpression+ . parenthesized+ . (<> " :: float4") $+ let+ y = fromRational x+ decimal = toStrict . toLazyByteString . floatDec+ in+ if isNaN y || isInfinite y+ then singleQuotedUtf8 (decimal y)+ else decimal y+instance Fractional+ (Expression grp lat with db params from (null 'PGfloat8)) where+ (/) = unsafeBinaryOp "/"+ fromRational x+ = UnsafeExpression+ . parenthesized+ . (<> " :: float8") $+ let+ y = fromRational x+ decimal = toStrict . toLazyByteString . doubleDec+ in+ if isNaN y || isInfinite y+ then singleQuotedUtf8 (decimal y)+ else decimal y+instance Fractional+ (Expression grp lat with db params from (null 'PGnumeric)) where+ (/) = unsafeBinaryOp "/" fromRational = UnsafeExpression- . fromString- . ($ "")- . showFFloat Nothing- . fromRat @Double+ . parenthesized+ . (<> " :: numeric")+ . toStrict+ . toLazyByteString+ . scientificBuilder+ . fromRational -instance (ty `In` PGNum, ty `In` PGFloating) => Floating- (Expression outer commons grp schemas params from (null ty)) where+instance Floating+ (Expression grp lat with db params from (null 'PGfloat4)) where pi = UnsafeExpression "pi()" exp = unsafeFunction "exp" log = unsafeFunction "ln"@@ -351,48 +537,109 @@ asinh x = log (x + sqrt (x*x + 1)) acosh x = log (x + sqrt (x*x - 1)) atanh x = log ((1 + x) / (1 - x)) / 2+instance Floating+ (Expression grp lat with db params from (null 'PGfloat8)) where+ pi = UnsafeExpression "pi()"+ exp = unsafeFunction "exp"+ log = unsafeFunction "ln"+ sqrt = unsafeFunction "sqrt"+ b ** x = UnsafeExpression $+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"+ logBase b y = log y / log b+ sin = unsafeFunction "sin"+ cos = unsafeFunction "cos"+ tan = unsafeFunction "tan"+ asin = unsafeFunction "asin"+ acos = unsafeFunction "acos"+ atan = unsafeFunction "atan"+ sinh x = (exp x - exp (-x)) / 2+ cosh x = (exp x + exp (-x)) / 2+ tanh x = sinh x / cosh x+ asinh x = log (x + sqrt (x*x + 1))+ acosh x = log (x + sqrt (x*x - 1))+ atanh x = log ((1 + x) / (1 - x)) / 2+instance Floating+ (Expression grp lat with db params from (null 'PGnumeric)) where+ pi = UnsafeExpression "pi()"+ exp = unsafeFunction "exp"+ log = unsafeFunction "ln"+ sqrt = unsafeFunction "sqrt"+ b ** x = UnsafeExpression $+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"+ logBase b y = log y / log b+ sin = unsafeFunction "sin"+ cos = unsafeFunction "cos"+ tan = unsafeFunction "tan"+ asin = unsafeFunction "asin"+ acos = unsafeFunction "acos"+ atan = unsafeFunction "atan"+ sinh x = (exp x - exp (-x)) / 2+ cosh x = (exp x + exp (-x)) / 2+ tanh x = sinh x / cosh x+ asinh x = log (x + sqrt (x*x + 1))+ acosh x = log (x + sqrt (x*x - 1))+ atanh x = log ((1 + x) / (1 - x)) / 2 -- | Contained by operators-class PGSubset container where- (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)+class PGSubset ty where+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) (@>) = unsafeBinaryOp "@>"- (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool) (<@) = unsafeBinaryOp "<@"+infix 4 @>+infix 4 <@ instance PGSubset 'PGjsonb instance PGSubset 'PGtsquery instance PGSubset ('PGvararray ty)+instance PGSubset ('PGrange ty) +-- | Intersection operator+class PGIntersect ty where+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+ (@&&) = unsafeBinaryOp "&&"+instance PGIntersect ('PGvararray ty)+instance PGIntersect ('PGrange ty)+ instance IsString- (Expression outer commons grp schemas params from (null 'PGtext)) where- fromString str = UnsafeExpression $- "E\'" <> fromString (escape =<< str) <> "\'"+ (Expression grp lat with db params from (null 'PGtext)) where+ fromString+ = UnsafeExpression+ . parenthesized+ . (<> " :: text")+ . escapeQuotedString instance IsString- (Expression outer commons grp schemas params from (null 'PGtsvector)) where- fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $- "E\'" <> fromString (escape =<< str) <> "\'"+ (Expression grp lat with db params from (null 'PGtsvector)) where+ fromString+ = UnsafeExpression+ . parenthesized+ . (<> " :: tsvector")+ . escapeQuotedString instance IsString- (Expression outer commons grp schemas params from (null 'PGtsquery)) where- fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $- "E\'" <> fromString (escape =<< str) <> "\'"+ (Expression grp lat with db params from (null 'PGtsquery)) where+ fromString+ = UnsafeExpression+ . parenthesized+ . (<> " :: tsquery")+ . escapeQuotedString instance Semigroup- (Expression outer commons grp schemas params from (null ('PGvararray ty))) where+ (Expression grp lat with db params from (null ('PGvararray ty))) where (<>) = unsafeBinaryOp "||" instance Semigroup- (Expression outer commons grp schemas params from (null 'PGjsonb)) where+ (Expression grp lat with db params from (null 'PGjsonb)) where (<>) = unsafeBinaryOp "||" instance Semigroup- (Expression outer commons grp schemas params from (null 'PGtext)) where+ (Expression grp lat with db params from (null 'PGtext)) where (<>) = unsafeBinaryOp "||" instance Semigroup- (Expression outer commons grp schemas params from (null 'PGtsvector)) where+ (Expression grp lat with db params from (null 'PGtsvector)) where (<>) = unsafeBinaryOp "||" instance Monoid- (Expression outer commons grp schemas params from (null 'PGtext)) where+ (Expression grp lat with db params from (null 'PGtext)) where mempty = fromString "" mappend = (<>) instance Monoid- (Expression outer commons grp schemas params from (null 'PGtsvector)) where+ (Expression grp lat with db params from (null 'PGtsvector)) where mempty = fromString "" mappend = (<>)
src/Squeal/PostgreSQL/Expression/Aggregate.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Aggregate-Description: Aggregate functions+Description: aggregate functions and arguments Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Aggregate functions+aggregate functions and arguments -} {-# LANGUAGE@@ -17,99 +17,124 @@ , LambdaCase , MultiParamTypeClasses , OverloadedStrings+ , PatternSynonyms , PolyKinds+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications , TypeFamilies , TypeOperators , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Aggregate- ( Aggregate (..)- , Distinction (..)+ ( -- * Aggregate+ Aggregate (..)+ -- * Aggregate Arguments+ , AggregateArg (..)+ , pattern All+ , pattern Alls+ , allNotNull+ , pattern Distinct+ , pattern Distincts+ , distinctNotNull+ , FilterWhere (..)+ -- * Aggregate Types , PGSum , PGAvg ) where -import Control.DeepSeq import Data.ByteString (ByteString)-import Data.Kind import GHC.TypeLits -import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP -import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Null+import Squeal.PostgreSQL.Expression.Sort+import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL {- | `Aggregate` functions compute a single result from a set of input values.-`Aggregate` functions can be used as `GroupedBy` `Expression`s as well+`Aggregate` functions can be used as `Grouped` `Expression`s as well as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s. -}-class Aggregate expr1 exprN aggr- | aggr -> expr1, aggr -> exprN where+class Aggregate arg expr | expr -> arg where -- | A special aggregation that does not require an input -- -- >>> :{ -- let- -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)+ -- expression :: Expression ('Grouped bys) '[] with db params from ('NotNull 'PGint8) -- expression = countStar -- in printSQL expression -- :} -- count(*)- countStar :: aggr ('NotNull 'PGint8)+ countStar :: expr lat with db params from ('NotNull 'PGint8) -- | >>> :{ -- let- -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)+ -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8) -- expression = count (All #col) -- in printSQL expression -- :} -- count(ALL "col") count- :: expr1 ty- -- ^ what to count- -> aggr ('NotNull 'PGint8)+ :: arg '[ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('NotNull 'PGint8) -- | >>> :{ -- let- -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)- -- expression = sum_ (Distinct #col)+ -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)+ -- expression = sum_ (Distinct #col & filterWhere (#col .< 100)) -- in printSQL expression -- :}- -- sum(DISTINCT "col")+ -- sum(DISTINCT "col") FILTER (WHERE ("col" < (100.0 :: numeric))) sum_- :: expr1 (null ty)- -> aggr ('Null (PGSum ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGSum ty)) -- | input values, including nulls, concatenated into an array+ --+ -- >>> :{+ -- let+ -- expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null ('PGvararray ('Null 'PGnumeric)))+ -- expression = arrayAgg (All #col & orderBy [AscNullsFirst #col] & filterWhere (#col .< 100))+ -- in printSQL expression+ -- :}+ -- array_agg(ALL "col" ORDER BY "col" ASC NULLS FIRST) FILTER (WHERE ("col" < (100.0 :: numeric))) arrayAgg- :: expr1 ty- -> aggr ('Null ('PGvararray ty))+ :: arg '[ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null ('PGvararray ty)) -- | aggregates values as a JSON array jsonAgg- :: expr1 ty- -> aggr ('Null 'PGjson)+ :: arg '[ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null 'PGjson) -- | aggregates values as a JSON array jsonbAgg- :: expr1 ty- -> aggr ('Null 'PGjsonb)+ :: arg '[ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null 'PGjsonb) {- | the bitwise AND of all non-null input values, or null if none >>> :{ let- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)+ expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) expression = bitAnd (Distinct #col) in printSQL expression :}@@ -117,16 +142,16 @@ -} bitAnd :: int `In` PGIntegral- => expr1 (null int)- -- ^ what to aggregate- -> aggr ('Null int)+ => arg '[null int] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null int) {- | the bitwise OR of all non-null input values, or null if none >>> :{ let- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)+ expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4) expression = bitOr (All #col) in printSQL expression :}@@ -134,307 +159,464 @@ -} bitOr :: int `In` PGIntegral- => expr1 (null int)- -- ^ what to aggregate- -> aggr ('Null int)+ => arg '[null int] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null int) {- | true if all input values are true, otherwise false >>> :{ let- winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)- winFun = boolAnd #col+ winFun :: WindowFunction 'Ungrouped '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)+ winFun = boolAnd (Window #col) in printSQL winFun :} bool_and("col") -} boolAnd- :: expr1 (null 'PGbool)- -- ^ what to aggregate- -> aggr ('Null 'PGbool)+ :: arg '[null 'PGbool] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null 'PGbool) {- | true if at least one input value is true, otherwise false >>> :{ let- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)+ expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) expression = boolOr (All #col) in printSQL expression :} bool_or(ALL "col") -} boolOr- :: expr1 (null 'PGbool)- -- ^ what to aggregate- -> aggr ('Null 'PGbool)+ :: arg '[null 'PGbool] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null 'PGbool) {- | equivalent to `boolAnd` >>> :{ let- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)+ expression :: Expression ('Grouped bys) '[] with db params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool) expression = every (Distinct #col) in printSQL expression :} every(DISTINCT "col") -} every- :: expr1 (null 'PGbool)- -- ^ what to aggregate- -> aggr ('Null 'PGbool)+ :: arg '[null 'PGbool] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null 'PGbool) {- |maximum value of expression across all input values-} max_- :: expr1 (null ty)- -- ^ what to maximize- -> aggr ('Null ty)+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null ty) -- | minimum value of expression across all input values min_- :: expr1 (null ty)- -- ^ what to minimize- -> aggr ('Null ty)+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null ty) -- | the average (arithmetic mean) of all input values avg- :: expr1 (null ty)- -- ^ what to average- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) {- | correlation coefficient >>> :{ let- expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)- expression = corr (All (#y *: #x))+ expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = corr (Alls (#y *: #x)) in printSQL expression :} corr(ALL "y", "x") -} corr- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) {- | population covariance >>> :{ let- expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)- expression = covarPop (All (#y *: #x))+ expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = covarPop (Alls (#y *: #x)) in printSQL expression :} covar_pop(ALL "y", "x") -} covarPop- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) {- | sample covariance >>> :{ let- winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)- winFun = covarSamp (#y *: #x)+ winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ winFun = covarSamp (Windows (#y *: #x)) in printSQL winFun :} covar_samp("y", "x") -} covarSamp- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) {- | average of the independent variable (sum(X)/N) >>> :{ let- expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)- expression = regrAvgX (All (#y *: #x))+ expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = regrAvgX (Alls (#y *: #x)) in printSQL expression :} regr_avgx(ALL "y", "x") -} regrAvgX- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) {- | average of the dependent variable (sum(Y)/N) >>> :{ let- winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)- winFun = regrAvgY (#y *: #x)+ winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ winFun = regrAvgY (Windows (#y *: #x)) in printSQL winFun :} regr_avgy("y", "x") -} regrAvgY- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) {- | number of input rows in which both expressions are nonnull >>> :{ let- winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)- winFun = regrCount (#y *: #x)+ winFun :: WindowFunction 'Ungrouped '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)+ winFun = regrCount (Windows (#y *: #x)) in printSQL winFun :} regr_count("y", "x") -} regrCount- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGint8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGint8) {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs+ >>> :{ let- expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)- expression = regrIntercept (All (#y *: #x))+ expression :: Expression ('Grouped g) '[] c s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)+ expression = regrIntercept (Alls (#y *: #x)) in printSQL expression :} regr_intercept(ALL "y", "x") -} regrIntercept- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_r2(Y, X)@, square of the correlation coefficient regrR2- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation -- determined by the (X, Y) pairs regrSlope- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N -- (“sum of squares” of the independent variable) regrSxx- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N -- (“sum of products” of independent times dependent variable) regrSxy- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N -- (“sum of squares” of the dependent variable) regrSyy- :: exprN '[null 'PGfloat8, null 'PGfloat8]- -> aggr ('Null 'PGfloat8)+ :: arg '[null 'PGfloat8, null 'PGfloat8] lat with db params from+ -- ^ arguments+ -> expr lat with db params from ('Null 'PGfloat8) -- | historical alias for `stddevSamp` stddev- :: expr1 (null ty)- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) -- | population standard deviation of the input values stddevPop- :: expr1 (null ty)- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) -- | sample standard deviation of the input values stddevSamp- :: expr1 (null ty)- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) -- | historical alias for `varSamp` variance- :: expr1 (null ty)- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) -- | population variance of the input values -- (square of the population standard deviation) varPop- :: expr1 (null ty)- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) -- | sample variance of the input values -- (square of the sample standard deviation) varSamp- :: expr1 (null ty)- -> aggr ('Null (PGAvg ty))+ :: arg '[null ty] lat with db params from+ -- ^ argument+ -> expr lat with db params from ('Null (PGAvg ty)) {- |-`Distinction`s are used for the input of `Aggregate` `Expression`s.-`All` invokes the aggregate once for each input row.-`Distinct` invokes the aggregate once for each distinct value of the expression-(or distinct set of values, for multiple expressions) found in the input+`AggregateArg`s are used for the input of `Aggregate` `Expression`s. -}-data Distinction (expr :: kind -> Type) (ty :: kind)- = All (expr ty)- | Distinct (expr ty)- deriving (GHC.Generic,Show,Eq,Ord)-instance NFData (Distinction (Expression outer commons grp schemas params from) ty)-instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where+data AggregateArg+ (xs :: [NullType])+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (from :: FromType)+ = AggregateAll+ { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs+ , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from]+ -- ^ `orderBy`+ , aggregateFilter :: [Condition 'Ungrouped lat with db params from]+ -- ^ `filterWhere`+ }+ | AggregateDistinct+ { aggregateArgs :: NP (Expression 'Ungrouped lat with db params from) xs+ , aggregateOrder :: [SortExpression 'Ungrouped lat with db params from]+ -- ^ `orderBy`+ , aggregateFilter :: [Condition 'Ungrouped lat with db params from]+ -- ^ `filterWhere`+ }++instance (HasUnique tab (Join from lat) row, Has col row ty)+ => IsLabel col (AggregateArg '[ty] lat with db params from) where+ fromLabel = All (fromLabel @col)+instance (Has tab (Join from lat) row, Has col row ty)+ => IsQualified tab col (AggregateArg '[ty] lat with db params from) where+ tab ! col = All (tab ! col)++instance SOP.SListI xs => RenderSQL (AggregateArg xs lat with db params from) where renderSQL = \case- All x -> "ALL" <+> renderSQL x- Distinct x -> "DISTINCT" <+> renderSQL x-instance SOP.SListI tys => RenderSQL- (Distinction (NP (Expression outer commons grp schemas params from)) tys) where- renderSQL = \case- All xs -> "ALL" <+> renderCommaSeparated renderSQL xs- Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs+ AggregateAll args sorts filters ->+ parenthesized+ ("ALL" <+> renderCommaSeparated renderSQL args<> renderSQL sorts)+ <> renderFilters filters+ AggregateDistinct args sorts filters ->+ parenthesized+ ("DISTINCT" <+> renderCommaSeparated renderSQL args <> renderSQL sorts)+ <> renderFilters filters+ where+ renderFilter wh = "FILTER" <+> parenthesized ("WHERE" <+> wh)+ renderFilters = \case+ [] -> ""+ wh:whs -> " " <> renderFilter (renderSQL (foldr (.&&) wh whs)) -instance Aggregate- (Distinction (Expression outer commons 'Ungrouped schemas params from))- (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))- (Expression outer commons ('Grouped bys) schemas params from) where- countStar = UnsafeExpression "count(*)"- count = unsafeAggregate1 "count"- sum_ = unsafeAggregate1 "sum"- arrayAgg = unsafeAggregate1 "array_agg"- jsonAgg = unsafeAggregate1 "json_agg"- jsonbAgg = unsafeAggregate1 "jsonb_agg"- bitAnd = unsafeAggregate1 "bit_and"- bitOr = unsafeAggregate1 "bit_or"- boolAnd = unsafeAggregate1 "bool_and"- boolOr = unsafeAggregate1 "bool_or"- every = unsafeAggregate1 "every"- max_ = unsafeAggregate1 "max"- min_ = unsafeAggregate1 "min"- avg = unsafeAggregate1 "avg"- corr = unsafeAggregateN "corr"- covarPop = unsafeAggregateN "covar_pop"- covarSamp = unsafeAggregateN "covar_samp"- regrAvgX = unsafeAggregateN "regr_avgx"- regrAvgY = unsafeAggregateN "regr_avgy"- regrCount = unsafeAggregateN "regr_count"- regrIntercept = unsafeAggregateN "regr_intercept"- regrR2 = unsafeAggregateN "regr_r2"- regrSlope = unsafeAggregateN "regr_slope"- regrSxx = unsafeAggregateN "regr_sxx"- regrSxy = unsafeAggregateN "regr_sxy"- regrSyy = unsafeAggregateN "regr_syy"- stddev = unsafeAggregate1 "stddev"- stddevPop = unsafeAggregate1 "stddev_pop"- stddevSamp = unsafeAggregate1 "stddev_samp"- variance = unsafeAggregate1 "variance"- varPop = unsafeAggregate1 "var_pop"- varSamp = unsafeAggregate1 "var_samp"+instance OrderBy (AggregateArg xs) 'Ungrouped where+ orderBy sorts1 = \case+ AggregateAll xs sorts0 whs -> AggregateAll xs (sorts0 ++ sorts1) whs+ AggregateDistinct xs sorts0 whs -> AggregateDistinct xs (sorts0 ++ sorts1) whs --- | escape hatch to define aggregate functions-unsafeAggregate1- :: ByteString -- ^ aggregate function- -> Distinction (Expression outer commons 'Ungrouped schemas params from) x- -> Expression outer commons ('Grouped bys) schemas params from y-unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)+-- | `All` invokes the aggregate on a single+-- argument once for each input row.+pattern All+ :: Expression 'Ungrouped lat with db params from x+ -- ^ argument+ -> AggregateArg '[x] lat with db params from+pattern All x = Alls (x :* Nil) -unsafeAggregateN+-- | `All` invokes the aggregate on multiple+-- arguments once for each input row.+pattern Alls+ :: NP (Expression 'Ungrouped lat with db params from) xs+ -- ^ arguments+ -> AggregateArg xs lat with db params from+pattern Alls xs = AggregateAll xs [] []++-- | `allNotNull` invokes the aggregate on a single+-- argument once for each input row where the argument+-- is not null+allNotNull+ :: Expression 'Ungrouped lat with db params from ('Null x)+ -- ^ argument+ -> AggregateArg '[ 'NotNull x] lat with db params from+allNotNull x = All (unsafeNotNull x) & filterWhere (not_ (isNull x))++{- |+`Distinct` invokes the aggregate once for each+distinct value of the expression found in the input.+-}+pattern Distinct+ :: Expression 'Ungrouped lat with db params from x+ -- ^ argument+ -> AggregateArg '[x] lat with db params from+pattern Distinct x = Distincts (x :* Nil)++{- |+`Distincts` invokes the aggregate once for each+distinct set of values, for multiple expressions, found in the input.+-}+pattern Distincts+ :: NP (Expression 'Ungrouped lat with db params from) xs+ -- ^ arguments+ -> AggregateArg xs lat with db params from+pattern Distincts xs = AggregateDistinct xs [] []++{- |+`distinctNotNull` invokes the aggregate once for each+distinct, not null value of the expression found in the input.+-}+distinctNotNull+ :: Expression 'Ungrouped lat with db params from ('Null x)+ -- ^ argument+ -> AggregateArg '[ 'NotNull x] lat with db params from+distinctNotNull x = Distinct (unsafeNotNull x) & filterWhere (not_ (isNull x))++-- | Permits filtering+-- `Squeal.PostgreSQL.Expression.Window.WindowArg`s and `AggregateArg`s+class FilterWhere arg grp | arg -> grp where+ {- |+ If `filterWhere` is specified, then only the input rows for which+ the `Condition` evaluates to true are fed to the aggregate function;+ other rows are discarded.+ -}+ filterWhere+ :: Condition grp lat with db params from+ -- ^ include rows which evaluate to true+ -> arg xs lat with db params from+ -> arg xs lat with db params from+instance FilterWhere AggregateArg 'Ungrouped where+ filterWhere wh = \case+ AggregateAll xs sorts whs -> AggregateAll xs sorts (wh : whs)+ AggregateDistinct xs sorts whs -> AggregateDistinct xs sorts (wh : whs)++instance Aggregate AggregateArg (Expression ('Grouped bys)) where+ countStar = UnsafeExpression "count(*)"+ count = unsafeAggregate "count"+ sum_ = unsafeAggregate "sum"+ arrayAgg = unsafeAggregate "array_agg"+ jsonAgg = unsafeAggregate "json_agg"+ jsonbAgg = unsafeAggregate "jsonb_agg"+ bitAnd = unsafeAggregate "bit_and"+ bitOr = unsafeAggregate "bit_or"+ boolAnd = unsafeAggregate "bool_and"+ boolOr = unsafeAggregate "bool_or"+ every = unsafeAggregate "every"+ max_ = unsafeAggregate "max"+ min_ = unsafeAggregate "min"+ avg = unsafeAggregate "avg"+ corr = unsafeAggregate "corr"+ covarPop = unsafeAggregate "covar_pop"+ covarSamp = unsafeAggregate "covar_samp"+ regrAvgX = unsafeAggregate "regr_avgx"+ regrAvgY = unsafeAggregate "regr_avgy"+ regrCount = unsafeAggregate "regr_count"+ regrIntercept = unsafeAggregate "regr_intercept"+ regrR2 = unsafeAggregate "regr_r2"+ regrSlope = unsafeAggregate "regr_slope"+ regrSxx = unsafeAggregate "regr_sxx"+ regrSxy = unsafeAggregate "regr_sxy"+ regrSyy = unsafeAggregate "regr_syy"+ stddev = unsafeAggregate "stddev"+ stddevPop = unsafeAggregate "stddev_pop"+ stddevSamp = unsafeAggregate "stddev_samp"+ variance = unsafeAggregate "variance"+ varPop = unsafeAggregate "var_pop"+ varSamp = unsafeAggregate "var_samp"++-- provides a nicer type error when we forget to group by+-- note that we need to make our 'a' polymorphic so that we can still match when it's ambiguous+instance ( TypeError ('Text "Cannot use aggregate functions to construct an Ungrouped Expression. Add a 'groupBy' to your TableExpression. If you want to aggregate across the entire result set, use 'groupBy Nil'.")+ , a ~ AggregateArg+ ) => Aggregate a (Expression 'Ungrouped) where+ countStar = impossibleAggregateError+ count = impossibleAggregateError+ sum_ = impossibleAggregateError+ arrayAgg = impossibleAggregateError+ jsonAgg = impossibleAggregateError+ jsonbAgg = impossibleAggregateError+ bitAnd = impossibleAggregateError+ bitOr = impossibleAggregateError+ boolAnd = impossibleAggregateError+ boolOr = impossibleAggregateError+ every = impossibleAggregateError+ max_ = impossibleAggregateError+ min_ = impossibleAggregateError+ avg = impossibleAggregateError+ corr = impossibleAggregateError+ covarPop = impossibleAggregateError+ covarSamp = impossibleAggregateError+ regrAvgX = impossibleAggregateError+ regrAvgY = impossibleAggregateError+ regrCount = impossibleAggregateError+ regrIntercept = impossibleAggregateError+ regrR2 = impossibleAggregateError+ regrSlope = impossibleAggregateError+ regrSxx = impossibleAggregateError+ regrSxy = impossibleAggregateError+ regrSyy = impossibleAggregateError+ stddev = impossibleAggregateError+ stddevPop = impossibleAggregateError+ stddevSamp = impossibleAggregateError+ variance = impossibleAggregateError+ varPop = impossibleAggregateError+ varSamp = impossibleAggregateError++-- | helper function for our errors above+impossibleAggregateError :: a+impossibleAggregateError = error "impossible; called aggregate function for Ungrouped even though the Aggregate instance has a type error constraint."++-- | escape hatch to define aggregate functions+unsafeAggregate :: SOP.SListI xs => ByteString -- ^ function- -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs- -> Expression outer commons ('Grouped bys) schemas params from y-unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)+ -> AggregateArg xs lat with db params from+ -> Expression ('Grouped bys) lat with db params from y+unsafeAggregate fun xs = UnsafeExpression $ fun <> renderSQL xs --- | A type family that calculates `PGSum``PGType` of+-- | A type family that calculates `PGSum` `PGType` of -- a given argument `PGType`. type family PGSum ty where PGSum 'PGint2 = 'PGint8
+ src/Squeal/PostgreSQL/Expression/Array.hs view
@@ -0,0 +1,291 @@+{-|+Module: Squeal.PostgreSQL.Expression.Array+Description: array functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++array functions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Array+ ( -- * Array Functions+ array+ , array0+ , array1+ , array2+ , cardinality+ , index+ , index1+ , index2+ , unnest+ , arrAny+ , arrAll+ , arrayAppend+ , arrayPrepend+ , arrayCat+ , arrayPosition+ , arrayPositionBegins+ , arrayPositions+ , arrayRemoveNull+ , arrayReplace+ , trimArray+ ) where++import Data.String+import Data.Word (Word64)+import GHC.TypeNats++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Null+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Query.From.Set+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | Construct an array.+--+-- >>> printSQL $ array [null_, false, true]+-- ARRAY[NULL, FALSE, TRUE]+array+ :: [Expression grp lat with db params from ty]+ -- ^ array elements+ -> Expression grp lat with db params from (null ('PGvararray ty))+array xs = UnsafeExpression $ "ARRAY" <>+ bracketed (commaSeparated (renderSQL <$> xs))++-- | Safely construct an empty array.+--+-- >>> printSQL $ array0 text+-- (ARRAY[] :: text[])+array0+ :: TypeExpression db ty+ -> Expression grp lat with db params from (null ('PGvararray ty))+array0 ty = array [] & astype (vararray ty)++{- | Construct a fixed length array.++>>> printSQL $ array1 (null_ :* false *: true)+ARRAY[NULL, FALSE, TRUE]++>>> :type array1 (null_ :* false *: true)+array1 (null_ :* false *: true)+ :: Expression+ grp+ lat+ with+ db+ params+ from+ (null ('PGfixarray '[3] ('Null 'PGbool)))+-}+array1+ :: (n ~ Length tys, SOP.All ((~) ty) tys)+ => NP (Expression grp lat with db params from) tys+ -- ^ array elements+ -> Expression grp lat with db params from (null ('PGfixarray '[n] ty))+array1 xs = UnsafeExpression $ "ARRAY" <>+ bracketed (renderCommaSeparated renderSQL xs)++{- | Construct a fixed size matrix.++>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))+ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]++>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))+array2 ((null_ :* false *: true) *: (false :* null_ *: true))+ :: Expression+ grp+ lat+ with+ db+ params+ from+ (null ('PGfixarray '[2, 3] ('Null 'PGbool)))+-}+array2+ :: ( SOP.All ((~) tys) tyss+ , SOP.All SOP.SListI tyss+ , Length tyss ~ n1+ , SOP.All ((~) ty) tys+ , Length tys ~ n2 )+ => NP (NP (Expression grp lat with db params from)) tyss+ -- ^ matrix elements+ -> Expression grp lat with db params from (null ('PGfixarray '[n1,n2] ty))+array2 xss = UnsafeExpression $ "ARRAY" <>+ bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)++-- | >>> printSQL $ cardinality (array [null_, false, true])+-- cardinality(ARRAY[NULL, FALSE, TRUE])+cardinality :: null ('PGvararray ty) --> null 'PGint8+cardinality = unsafeFunction "cardinality"++-- | >>> printSQL $ array [null_, false, true] & index 2+-- (ARRAY[NULL, FALSE, TRUE])[2]+index+ :: Word64 -- ^ index+ -> null ('PGvararray ty) --> NullifyType ty+index i arr = UnsafeExpression $+ parenthesized (renderSQL arr) <> "[" <> fromString (show i) <> "]"++-- | Typesafe indexing of fixed length arrays.+--+-- >>> printSQL $ array1 (true *: false) & index1 @1+-- (ARRAY[TRUE, FALSE])[1]+index1+ :: forall i n ty+ . (1 <= i, i <= n, KnownNat i)+ => 'NotNull ('PGfixarray '[n] ty) --> ty+ -- ^ vector index+index1 arr = UnsafeExpression $+ parenthesized (renderSQL arr)+ <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]"++-- | Typesafe indexing of fixed size matrices.+--+-- >>> printSQL $ array2 ((true *: false) *: (false *: true)) & index2 @1 @2+-- (ARRAY[[TRUE, FALSE], [FALSE, TRUE]])[1][2]+index2+ :: forall i j m n ty+ . ( 1 <= i, i <= m, KnownNat i+ , 1 <= j, j <= n, KnownNat j+ )+ => 'NotNull ('PGfixarray '[m,n] ty) --> ty+ -- ^ matrix index+index2 arr = UnsafeExpression $+ parenthesized (renderSQL arr)+ <> "[" <> fromString (show (natVal (SOP.Proxy @i))) <> "]"+ <> "[" <> fromString (show (natVal (SOP.Proxy @j))) <> "]"++-- | Expand an array to a set of rows+--+-- >>> printSQL $ unnest (array [null_, false, true])+-- unnest(ARRAY[NULL, FALSE, TRUE])+unnest :: null ('PGvararray ty) -|-> ("unnest" ::: '["unnest" ::: ty])+unnest = unsafeSetFunction "unnest"++{- |+The right-hand side is a parenthesized expression,+which must yield an array value. The left-hand expression+is evaluated and compared to each element of the array using+the given `Operator`, which must yield a Boolean result.+The result of `arrAll` is `true` if all comparisons yield true+(including the case where the array has zero elements).+The result is `false` if any false result is found.++If the array expression yields a null array,+the result of `arrAll` will be null. If the left-hand expression yields null,+the result of `arrAll` is ordinarily null+(though a non-strict comparison `Operator`+could possibly yield a different result).+Also, if the right-hand array contains any null+elements and no false comparison result is obtained,+the result of `arrAll` will be null, not true+(again, assuming a strict comparison `Operator`).+This is in accordance with SQL's normal rules for Boolean+combinations of null values.++>>> printSQL $ arrAll true (.==) (array [true, false, null_])+(TRUE = ALL (ARRAY[TRUE, FALSE, NULL]))+>>> printSQL $ arrAll "hi" like (array ["bi","hi"])+((E'hi' :: text) LIKE ALL (ARRAY[(E'bi' :: text), (E'hi' :: text)]))+-}+arrAll+ :: Expression grp lat with db params from ty1 -- ^ expression+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator+ -> Expression grp lat with db params from (null ('PGvararray ty2)) -- ^ array+ -> Condition grp lat with db params from+arrAll x (?) xs = x ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL xs))++{- |+The right-hand side is a parenthesized expression, which must yield an array+value. The left-hand expression is evaluated and compared to each element of+the array using the given `Operator`, which must yield a Boolean result. The+result of `arrAny` is `true` if any true result is obtained. The result is+`false` if no true result is found (including the case where the array+has zero elements).++If the array expression yields a null array, the result of `arrAny` will+be null. If the left-hand expression yields null, the result of `arrAny` is+ordinarily null (though a non-strict comparison `Operator` could possibly+yield a different result). Also, if the right-hand array contains any+null elements and no true comparison result is obtained, the result of+`arrAny` will be null, not false+(again, assuming a strict comparison `Operator`).+This is in accordance with SQL's normal rules for+Boolean combinations of null values.++>>> printSQL $ arrAny true (.==) (array [true, false, null_])+(TRUE = ANY (ARRAY[TRUE, FALSE, NULL]))+>>> printSQL $ arrAny "hi" like (array ["bi","hi"])+((E'hi' :: text) LIKE ANY (ARRAY[(E'bi' :: text), (E'hi' :: text)]))+-}+arrAny+ :: Expression grp lat with db params from ty1 -- ^ expression+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator+ -> Expression grp lat with db params from (null ('PGvararray ty2)) -- ^ array+ -> Condition grp lat with db params from+arrAny x (?) xs = x ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL xs))++arrayAppend :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty)+arrayAppend = unsafeFunctionN "array_append"++arrayPrepend :: '[ty, null ('PGvararray ty)] ---> null ('PGvararray ty)+arrayPrepend = unsafeFunctionN "array_prepend"++arrayCat+ :: '[null ('PGvararray ty), null ('PGvararray ty)]+ ---> null ('PGvararray ty)+arrayCat = unsafeFunctionN "array_cat"++arrayPosition :: '[null ('PGvararray ty), ty] ---> 'Null 'PGint8+arrayPosition = unsafeFunctionN "array_position"++arrayPositionBegins+ :: '[null ('PGvararray ty), ty, null 'PGint8] ---> 'Null 'PGint8+arrayPositionBegins = unsafeFunctionN "array_position"++arrayPositions+ :: '[null ('PGvararray ty), ty]+ ---> null ('PGvararray ('NotNull 'PGint8))+arrayPositions = unsafeFunctionN "array_positions"++arrayRemove :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty)+arrayRemove = unsafeFunctionN "array_remove"++arrayRemoveNull :: null ('PGvararray ('Null ty)) --> null ('PGvararray ('NotNull ty))+arrayRemoveNull arr = UnsafeExpression (renderSQL (arrayRemove (arr *: null_)))++arrayReplace+ :: '[null ('PGvararray ty), ty, ty]+ ---> null ('PGvararray ty)+arrayReplace = unsafeFunctionN "array_replace"++trimArray+ :: '[null ('PGvararray ty), 'NotNull 'PGint8]+ ---> null ('PGvararray ty)+trimArray = unsafeFunctionN "trim_array"
− src/Squeal/PostgreSQL/Expression/Collection.hs
@@ -1,169 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Expression.Collection-Description: Array and composite functions-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--Array and composite functions--}--{-# LANGUAGE- AllowAmbiguousTypes- , DataKinds- , FlexibleContexts- , FlexibleInstances- , MultiParamTypeClasses- , OverloadedLabels- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , TypeOperators- , UndecidableInstances-#-}--module Squeal.PostgreSQL.Expression.Collection- ( array- , array1- , array2- , cardinality- , index- , unnest- , row- , field- ) where--import Data.String-import Data.Word (Word64)--import qualified Generics.SOP as SOP--import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Expression.SetOf-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema---- $setup--- >>> import Squeal.PostgreSQL---- | >>> printSQL $ array [null_, false, true]--- ARRAY[NULL, FALSE, TRUE]-array- :: [Expression outer commons grp schemas params from ty]- -- ^ array elements- -> Expression outer commons grp schemas params from (null ('PGvararray ty))-array xs = UnsafeExpression $ "ARRAY" <>- bracketed (commaSeparated (renderSQL <$> xs))--{- | construct a 1-dimensional fixed length array-->>> printSQL $ array1 (null_ :* false *: true)-ARRAY[NULL, FALSE, TRUE]-->>> :type array1 (null_ :* false *: true)-array1 (null_ :* false *: true)- :: Expression- outer- commons- grp- schemas- params- from- (null ('PGfixarray '[3] ('Null 'PGbool)))--}-array1- :: (n ~ Length tys, SOP.All ((~) ty) tys)- => NP (Expression outer commons grp schemas params from) tys- -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))-array1 xs = UnsafeExpression $ "ARRAY" <>- bracketed (renderCommaSeparated renderSQL xs)--{- | construct a 2-dimensional fixed length array-->>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))-ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]-->>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))-array2 ((null_ :* false *: true) *: (false :* null_ *: true))- :: Expression- outer- commons- grp- schemas- params- from- (null ('PGfixarray '[2, 3] ('Null 'PGbool)))--}-array2- :: ( SOP.All ((~) tys) tyss- , SOP.All SOP.SListI tyss- , Length tyss ~ n1- , SOP.All ((~) ty) tys- , Length tys ~ n2 )- => NP (NP (Expression outer commons grp schemas params from)) tyss- -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))-array2 xss = UnsafeExpression $ "ARRAY" <>- bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)---- | >>> printSQL $ cardinality (array [null_, false, true])--- cardinality(ARRAY[NULL, FALSE, TRUE])-cardinality :: null ('PGvararray ty) :--> null 'PGint8-cardinality = unsafeFunction "cardinality"---- | >>> printSQL $ array [null_, false, true] & index 2--- (ARRAY[NULL, FALSE, TRUE])[2]-index- :: Word64 -- ^ index- -> null ('PGvararray ty) :--> NullifyType ty-index n expr = UnsafeExpression $- parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"---- | Expand an array to a set of rows-unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]-unnest = unsafeSetOfFunction---- | A row constructor is an expression that builds a row value--- (also called a composite value) using values for its member fields.------ >>> :{--- type Complex = 'PGcomposite--- '[ "real" ::: 'NotNull 'PGfloat8--- , "imaginary" ::: 'NotNull 'PGfloat8 ]--- :}------ >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)--- >>> printSQL i--- ROW(0, 1)-row- :: SOP.SListI row- => NP (Aliased (Expression outer commons grp schemas params from)) row- -- ^ zero or more expressions for the row field values- -> Expression outer commons grp schemas params from (null ('PGcomposite row))-row exprs = UnsafeExpression $ "ROW" <> parenthesized- (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)---- | >>> :{--- type Complex = 'PGcomposite--- '[ "real" ::: 'NotNull 'PGfloat8--- , "imaginary" ::: 'NotNull 'PGfloat8 ]--- type Schema = '["complex" ::: 'Typedef Complex]--- :}------ >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)--- >>> printSQL $ i & field #complex #imaginary--- (ROW(0, 1)::"complex")."imaginary"-field- :: ( Has sch schemas schema- , Has tydef schema ('Typedef ('PGcomposite row))- , Has field row ty)- => QualifiedAlias sch tydef -- ^ row type- -> Alias field -- ^ field name- -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))- -> Expression outer commons grp schemas params from ty-field td fld expr = UnsafeExpression $- parenthesized (renderSQL expr <> "::" <> renderSQL td)- <> "." <> renderSQL fld
src/Squeal/PostgreSQL/Expression/Comparison.hs view
@@ -1,34 +1,39 @@ {-| Module: Squeal.PostgreSQL.Expression.Comparison-Description: Comparison expressions+Description: comparison functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Comparison functions and operators+comparison functions and operators -} {-# LANGUAGE OverloadedStrings , RankNTypes- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators #-} module Squeal.PostgreSQL.Expression.Comparison- ( (.==)+ ( -- * Comparison Operators+ (.==) , (./=) , (.>=) , (.<) , (.<=) , (.>)+ -- * Comparison Functions , greatest , least+ -- * Between , BetweenExpr , between , notBetween , betweenSymmetric , notBetweenSymmetric+ -- * Null Comparison , isDistinctFrom , isNotDistinctFrom , isTrue@@ -44,7 +49,7 @@ import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -88,7 +93,7 @@ (.>) = unsafeBinaryOp ">" infix 4 .> --- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)+-- | >>> let expr = greatest [param @1] currentTimestamp -- >>> printSQL expr -- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP) greatest :: FunctionVar ty ty ty@@ -103,11 +108,11 @@ A @RankNType@ for comparison expressions like `between`. -} type BetweenExpr- = forall outer commons grp schemas params from ty- . Expression outer commons grp schemas params from ty- -> ( Expression outer commons grp schemas params from ty- , Expression outer commons grp schemas params from ty ) -- ^ bounds- -> Condition outer commons grp schemas params from+ = forall grp lat with db params from ty+ . Expression grp lat with db params from ty+ -> ( Expression grp lat with db params from ty+ , Expression grp lat with db params from ty ) -- ^ bounds+ -> Condition grp lat with db params from unsafeBetweenExpr :: ByteString -> BetweenExpr unsafeBetweenExpr fun a (x,y) = UnsafeExpression $@@ -146,7 +151,7 @@ >>> printSQL $ true `isDistinctFrom` null_ (TRUE IS DISTINCT FROM NULL) -}-isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)+isDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM" {- | equal, treating null like an ordinary value@@ -154,7 +159,7 @@ >>> printSQL $ true `isNotDistinctFrom` null_ (TRUE IS NOT DISTINCT FROM NULL) -}-isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)+isNotDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool) isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM" {- | is true@@ -162,45 +167,45 @@ >>> printSQL $ true & isTrue (TRUE IS TRUE) -}-isTrue :: null0 'PGbool :--> null1 'PGbool-isTrue = unsafeUnaryOpR "IS TRUE"+isTrue :: null0 'PGbool --> null1 'PGbool+isTrue = unsafeRightOp "IS TRUE" {- | is false or unknown >>> printSQL $ true & isNotTrue (TRUE IS NOT TRUE) -}-isNotTrue :: null0 'PGbool :--> null1 'PGbool-isNotTrue = unsafeUnaryOpR "IS NOT TRUE"+isNotTrue :: null0 'PGbool --> null1 'PGbool+isNotTrue = unsafeRightOp "IS NOT TRUE" {- | is false >>> printSQL $ true & isFalse (TRUE IS FALSE) -}-isFalse :: null0 'PGbool :--> null1 'PGbool-isFalse = unsafeUnaryOpR "IS FALSE"+isFalse :: null0 'PGbool --> null1 'PGbool+isFalse = unsafeRightOp "IS FALSE" {- | is true or unknown >>> printSQL $ true & isNotFalse (TRUE IS NOT FALSE) -}-isNotFalse :: null0 'PGbool :--> null1 'PGbool-isNotFalse = unsafeUnaryOpR "IS NOT FALSE"+isNotFalse :: null0 'PGbool --> null1 'PGbool+isNotFalse = unsafeRightOp "IS NOT FALSE" {- | is unknown >>> printSQL $ true & isUnknown (TRUE IS UNKNOWN) -}-isUnknown :: null0 'PGbool :--> null1 'PGbool-isUnknown = unsafeUnaryOpR "IS UNKNOWN"+isUnknown :: null0 'PGbool --> null1 'PGbool+isUnknown = unsafeRightOp "IS UNKNOWN" {- | is true or false >>> printSQL $ true & isNotUnknown (TRUE IS NOT UNKNOWN) -}-isNotUnknown :: null0 'PGbool :--> null1 'PGbool-isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"+isNotUnknown :: null0 'PGbool --> null1 'PGbool+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
+ src/Squeal/PostgreSQL/Expression/Composite.hs view
@@ -0,0 +1,95 @@+{-|+Module: Squeal.PostgreSQL.Expression.Composite+Description: composite functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++composite functions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Composite+ ( -- * Composite Functions+ row+ , rowStar+ , field+ ) where++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | A row constructor is an expression that builds a row value+-- (also called a composite value) using values for its member fields.+--+-- >>> :{+-- type Complex = 'PGcomposite+-- '[ "real" ::: 'NotNull 'PGfloat8+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]+-- :}+--+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp lat with db params from ('NotNull Complex)+-- >>> printSQL i+-- ROW((0.0 :: float8), (1.0 :: float8))+row+ :: SOP.SListI row+ => NP (Aliased (Expression grp lat with db params from)) row+ -- ^ zero or more expressions for the row field values+ -> Expression grp lat with db params from (null ('PGcomposite row))+row exprs = UnsafeExpression $ "ROW" <> parenthesized+ (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)++-- | A row constructor on all columns in a table expression.+rowStar+ :: Has tab from row+ => Alias tab -- ^ intermediate table+ -> Expression grp lat with db params from (null ('PGcomposite row))+rowStar tab = UnsafeExpression $ "ROW" <>+ parenthesized (renderSQL tab <> ".*")++-- | >>> :{+-- type Complex = 'PGcomposite+-- '[ "real" ::: 'NotNull 'PGfloat8+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]+-- type Schema = '["complex" ::: 'Typedef Complex]+-- :}+--+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression lat '[] grp (Public Schema) from params ('NotNull Complex)+-- >>> printSQL $ i & field #complex #imaginary+-- (ROW((0.0 :: float8), (1.0 :: float8))::"complex")."imaginary"+field+ :: ( relss ~ DbRelations db+ , Has sch relss rels+ , Has rel rels row+ , Has field row ty+ )+ => QualifiedAlias sch rel -- ^ row type+ -> Alias field -- ^ field name+ -> Expression grp lat with db params from ('NotNull ('PGcomposite row))+ -> Expression grp lat with db params from ty+field rel fld expr = UnsafeExpression $+ parenthesized (renderSQL expr <> "::" <> renderSQL rel)+ <> "." <> renderSQL fld
+ src/Squeal/PostgreSQL/Expression/Default.hs view
@@ -0,0 +1,60 @@+{-|+Module: Squeal.PostgreSQL.Expression.Default+Description: optional expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++optional expressions+-}++{-# LANGUAGE+ DataKinds+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , PatternSynonyms+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes+ , TypeOperators+#-}++module Squeal.PostgreSQL.Expression.Default+ ( -- * Default+ Optional (..)+ , mapOptional+ , pattern NotDefault+ ) where++import Data.Kind+import Generics.SOP++import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- | `Optional` is either `Default` or `Set`ting of a value,+-- parameterized by an appropriate `Optionality`.+data Optional (expr :: k -> Type) (ty :: (Optionality, k)) where+ -- | Use the `Default` value for a column.+ Default :: Optional expr ('Def :=> ty)+ -- | `Set` a value for a column.+ Set :: expr ty -> Optional expr (def :=> ty)++instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where+ renderSQL = \case+ Default -> "DEFAULT"+ Set x -> renderSQL x++-- | Map a function over an `Optional` expression.+mapOptional+ :: (expr x -> expr y)+ -> Optional expr (def :=> x)+ -> Optional expr (def :=> y)+mapOptional f = \case+ Default -> Default+ Set x -> Set (f x)++-- | `NotDefault` pattern analagous to `Just`.+pattern NotDefault :: ty -> Optional I ('Def :=> ty)+pattern NotDefault x = Set (I x)
+ src/Squeal/PostgreSQL/Expression/Inline.hs view
@@ -0,0 +1,363 @@+{-|+Module: Squeal.PostgreSQL.Expression.Inline+Description: inline expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++inline expressions+-}++{-# LANGUAGE+ DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , MultiParamTypeClasses+ , MultiWayIf+ , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , TypeSynonymInstances+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Inline+ ( -- * Inline+ Inline (..)+ , InlineParam (..)+ , InlineField (..)+ , inlineFields+ , InlineColumn (..)+ , inlineColumns+ ) where++import Data.Binary.Builder (toLazyByteString)+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec)+import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.Functor.Const (Const(Const))+import Data.Functor.Constant (Constant(Constant))+import Data.Int (Int16, Int32, Int64)+import Data.Kind (Type)+import Data.Scientific (Scientific)+import Data.String+import Data.Text (Text)+import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, UTCTime)+import Data.Time.Format.ISO8601 (formatShow, timeOfDayAndOffsetFormat, FormatExtension(ExtendedFormat), iso8601Show)+import Data.Time.Calendar (Day)+import Data.Time.LocalTime (LocalTime, TimeOfDay, TimeZone)+import Data.UUID.Types (UUID, toASCIIBytes)+import Data.Vector (Vector, toList)+import Database.PostgreSQL.LibPQ (Oid(Oid))+import GHC.TypeLits++import qualified Data.Aeson as JSON+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy (Text)+import qualified Data.Text.Lazy as Lazy.Text+import qualified Generics.SOP as SOP+import qualified Generics.SOP.Record as SOP++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Array+import Squeal.PostgreSQL.Expression.Default+import Squeal.PostgreSQL.Expression.Composite+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Null+import Squeal.PostgreSQL.Expression.Range+import Squeal.PostgreSQL.Expression.Time+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.PG+import Squeal.PostgreSQL.Type.Schema++{- |+The `Inline` class allows embedding a Haskell value directly+as an `Expression` using `inline`.++>>> printSQL (inline 'a')+(E'a' :: char(1))++>>> printSQL (inline (1 :: Double))+(1.0 :: float8)++>>> printSQL (inline (Json ([1, 2] :: [Double])))+('[1.0,2.0]' :: json)++>>> printSQL (inline (Enumerated GT))+'GT'+-}+class Inline x where inline :: x -> Expr (null (PG x))+instance Inline Bool where+ inline = \case+ True -> true+ False -> false+instance JSON.ToJSON x => Inline (Json x) where+ inline (Json x)+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . toStrict+ . JSON.encode+ $ x+instance JSON.ToJSON x => Inline (Jsonb x) where+ inline (Jsonb x)+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . toStrict+ . JSON.encode+ $ x+instance Inline Char where+ inline chr = inferredtype . UnsafeExpression $+ "E\'" <> fromString (escape chr) <> "\'"+instance Inline String where inline x = fromString x+instance Inline Int16 where+ inline x+ = inferredtype+ . UnsafeExpression+ . toStrict+ . toLazyByteString+ . int16Dec+ $ x+instance Inline Int32 where+ inline x+ = inferredtype+ . UnsafeExpression+ . toStrict+ . toLazyByteString+ . int32Dec+ $ x+instance Inline Int64 where+ inline x =+ if x == minBound+ -- For some reason Postgres throws an error with+ -- (-9223372036854775808 :: int8)+ -- even though it's a valid lowest value for int8+ then inline (x+1) - 1+ else inferredtype+ . UnsafeExpression+ . toStrict+ . toLazyByteString+ $ int64Dec x+instance Inline Float where+ inline x = inferredtype . UnsafeExpression $+ if isNaN x || isInfinite x+ then singleQuotedUtf8 (decimal x)+ else decimal x+ where+ decimal = toStrict . toLazyByteString . floatDec+instance Inline Double where+ inline x = inferredtype . UnsafeExpression $+ if isNaN x || isInfinite x+ then singleQuotedUtf8 (decimal x)+ else decimal x+ where+ decimal = toStrict . toLazyByteString . doubleDec+instance Inline Scientific where+ inline x+ = inferredtype+ . UnsafeExpression+ . toStrict+ . toLazyByteString+ . scientificBuilder+ $ x+instance Inline Text where inline x = fromString . Text.unpack $ x+instance Inline Lazy.Text where inline x = fromString . Lazy.Text.unpack $ x+instance (KnownNat n, 1 <= n) => Inline (VarChar n) where+ inline x+ = inferredtype+ . UnsafeExpression+ . escapeQuotedText+ . getVarChar+ $ x+instance (KnownNat n, 1 <= n) => Inline (FixChar n) where+ inline x+ = inferredtype+ . UnsafeExpression+ . escapeQuotedText+ . getFixChar+ $ x+instance Inline x => Inline (Const x tag) where inline (Const x) = inline x+instance Inline x => Inline (SOP.K x tag) where inline (SOP.K x) = inline x+instance Inline x => Inline (Constant x tag) where+ inline (Constant x) = inline x+instance Inline DiffTime where+ inline dt =+ let+ picosecs = diffTimeToPicoseconds dt+ (secs,leftover) = picosecs `quotRem` 1000000000000+ microsecs = leftover `quot` 1000000+ in+ inferredtype $+ interval_ (fromIntegral secs) Seconds+ +! interval_ (fromIntegral microsecs) Microseconds+instance Inline Day where+ inline x+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show+ $ x+instance Inline UTCTime where+ inline x+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show+ $ x+instance Inline (TimeOfDay, TimeZone) where+ inline x+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . formatShow (timeOfDayAndOffsetFormat ExtendedFormat)+ $ x+instance Inline TimeOfDay where+ inline x+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show+ $ x+instance Inline LocalTime where+ inline x+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . iso8601Show+ $ x+instance Inline (Range Int32) where+ inline x = range int4range . fmap (\y -> inline y) $ x+instance Inline (Range Int64) where+ inline x = range int8range . fmap (\y -> inline y) $ x+instance Inline (Range Scientific) where+ inline x = range numrange . fmap (\y -> inline y) $ x+instance Inline (Range LocalTime) where+ inline x = range tsrange . fmap (\y -> inline y) $ x+instance Inline (Range UTCTime) where+ inline x = range tstzrange . fmap (\y -> inline y) $ x+instance Inline (Range Day) where+ inline x = range daterange . fmap (\y -> inline y) $ x+instance Inline UUID where+ inline x+ = inferredtype+ . UnsafeExpression+ . singleQuotedUtf8+ . toASCIIBytes+ $ x+instance Inline Money where+ inline moolah = inferredtype . UnsafeExpression $+ fromString (show dollars)+ <> "." <> fromString (show pennies)+ where+ (dollars,pennies) = cents moolah `divMod` 100+instance InlineParam x (NullPG x)+ => Inline (VarArray [x]) where+ inline (VarArray xs) = array ((\x -> inlineParam x) <$> xs)+instance InlineParam x (NullPG x)+ => Inline (VarArray (Vector x)) where+ inline (VarArray xs) = array ((\x -> inlineParam x) <$> toList xs)+instance Inline Oid where+ inline (Oid o) = inferredtype . UnsafeExpression . fromString $ show o+instance+ ( SOP.IsEnumType x+ , SOP.HasDatatypeInfo x+ ) => Inline (Enumerated x) where+ inline (Enumerated x) =+ let+ gshowConstructor+ :: NP SOP.ConstructorInfo xss+ -> SOP.SOP SOP.I xss+ -> String+ gshowConstructor Nil _ = ""+ gshowConstructor (constructor :* _) (SOP.SOP (SOP.Z _)) =+ SOP.constructorName constructor+ gshowConstructor (_ :* constructors) (SOP.SOP (SOP.S xs)) =+ gshowConstructor constructors (SOP.SOP xs)+ in+ UnsafeExpression+ . singleQuotedUtf8+ . fromString+ . gshowConstructor+ (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x)))+ . SOP.from+ $ x+instance+ ( SOP.IsRecord x xs+ , SOP.AllZip InlineField xs (RowPG x)+ ) => Inline (Composite x) where+ inline (Composite x)+ = row+ . SOP.htrans (SOP.Proxy @InlineField) inlineField+ . SOP.toRecord+ $ x++-- | Lifts `Inline` to `NullType`s.+class InlineParam x ty where inlineParam :: x -> Expr ty+instance (Inline x, pg ~ PG x) => InlineParam x ('NotNull pg) where inlineParam = inline+instance (Inline x, pg ~ PG x) => InlineParam (Maybe x) ('Null pg) where+ inlineParam x = maybe null_ (\y -> inline y) x++-- | Lifts `Inline` to fields.+class InlineField+ (field :: (Symbol, Type))+ (fieldpg :: (Symbol, NullType)) where+ inlineField+ :: SOP.P field+ -> Aliased (Expression grp lat with db params from) fieldpg+instance (KnownSymbol alias, InlineParam x ty)+ => InlineField (alias ::: x) (alias ::: ty) where+ inlineField (SOP.P x) = inlineParam x `as` Alias @alias++-- | Inline a Haskell record as a row of expressions.+inlineFields+ :: ( SOP.IsRecord hask fields+ , SOP.AllZip InlineField fields row )+ => hask -- ^ record+ -> NP (Aliased (Expression 'Ungrouped '[] with db params '[])) row+inlineFields+ = SOP.htrans (SOP.Proxy @InlineField) inlineField+ . SOP.toRecord+++-- | Lifts `Inline` to a column entry+class InlineColumn+ (field :: (Symbol, Type))+ (column :: (Symbol, ColumnType)) where+ -- | Haskell record field as a inline column+ inlineColumn+ :: SOP.P field+ -> Aliased (Optional (Expression grp lat with db params from)) column+instance (KnownSymbol col, InlineParam x ty)+ => InlineColumn (col ::: x) (col ::: 'NoDef :=> ty) where+ inlineColumn (SOP.P x) = Set (inlineParam x) `as` (Alias @col)+instance (KnownSymbol col, InlineParam x ty)+ => InlineColumn+ (col ::: Optional SOP.I ('Def :=> x))+ (col ::: 'Def :=> ty) where+ inlineColumn (SOP.P optional) = case optional of+ Default -> Default `as` (Alias @col)+ Set (SOP.I x) -> Set (inlineParam x) `as` (Alias @col)++-- | Inline a Haskell record as a list of columns.+inlineColumns+ :: ( SOP.IsRecord hask xs+ , SOP.AllZip InlineColumn xs columns )+ => hask -- ^ record+ -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[]))) columns+inlineColumns+ = SOP.htrans (SOP.Proxy @InlineColumn) inlineColumn+ . SOP.toRecord
src/Squeal/PostgreSQL/Expression/Json.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Json-Description: Json and Jsonb functions and operators+Description: json and jsonb functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Json and Jsonb functions and operators+json and jsonb functions and operators -} {-# LANGUAGE@@ -25,18 +25,18 @@ #-} module Squeal.PostgreSQL.Expression.Json- ( -- * Json and Jsonb operators+ ( -- * Json and Jsonb Operators (.->) , (.->>) , (.#>) , (.#>>)- -- * Jsonb operators+ -- * Jsonb Operators , (.?) , (.?|) , (.?&) , (.-.) , (#-.)- -- * Json and Jsonb functions+ -- * Json and Jsonb Functions , toJson , toJsonb , arrayToJson@@ -57,11 +57,13 @@ , jsonbSet , jsonbInsert , jsonbPretty- -- * Json and Jsonb set returning functions+ -- * Json and Jsonb Set Functions , jsonEach , jsonbEach , jsonEachText+ , jsonArrayElementsText , jsonbEachText+ , jsonbArrayElementsText , jsonObjectKeys , jsonbObjectKeys , JsonPopulateFunction@@ -79,14 +81,14 @@ import Data.ByteString (ByteString) import GHC.TypeLits -import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Expression.SetOf import Squeal.PostgreSQL.Expression.Type-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Query.From+import Squeal.PostgreSQL.Query.From.Set import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema import qualified Generics.SOP as SOP @@ -188,7 +190,7 @@ -- otherwise, a scalar value is produced. For any scalar type other than a -- number, a Boolean, or a null value, the text representation will be used, in -- such a fashion that it is a valid json value.-toJson :: null ty :--> null 'PGjson+toJson :: null ty --> null 'PGjson toJson = unsafeFunction "to_json" -- | Returns the value as jsonb. Arrays and composites are converted@@ -197,26 +199,26 @@ -- otherwise, a scalar value is produced. For any scalar type other than a -- number, a Boolean, or a null value, the text representation will be used, in -- such a fashion that it is a valid jsonb value.-toJsonb :: null ty :--> null 'PGjsonb+toJsonb :: null ty --> null 'PGjsonb toJsonb = unsafeFunction "to_jsonb" -- | Returns the array as a JSON array. A PostgreSQL multidimensional array -- becomes a JSON array of arrays.-arrayToJson :: null ('PGvararray ty) :--> null 'PGjson+arrayToJson :: null ('PGvararray ty) --> null 'PGjson arrayToJson = unsafeFunction "array_to_json" -- | Returns the row as a JSON object.-rowToJson :: null ('PGcomposite ty) :--> null 'PGjson+rowToJson :: null ('PGcomposite ty) --> null 'PGjson rowToJson = unsafeFunction "row_to_json" -- | Builds a possibly-heterogeneously-typed JSON array out of a variadic -- argument list.-jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson jsonBuildArray = unsafeFunctionN "json_build_array" -- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a -- variadic argument list.-jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb jsonbBuildArray = unsafeFunctionN "jsonb_build_array" -- | Builds a possibly-heterogeneously-typed JSON object out of a variadic@@ -224,10 +226,10 @@ -- and values. class SOP.SListI tys => JsonBuildObject tys where - jsonBuildObject :: FunctionN tys (null 'PGjson)+ jsonBuildObject :: tys ---> null 'PGjson jsonBuildObject = unsafeFunctionN "json_build_object" - jsonbBuildObject :: FunctionN tys (null 'PGjsonb)+ jsonbBuildObject :: tys ---> null 'PGjsonb jsonbBuildObject = unsafeFunctionN "jsonb_build_object" instance JsonBuildObject '[]@@ -240,7 +242,7 @@ -- which are taken as a key/value pair. jsonObject :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))- :--> null 'PGjson+ --> null 'PGjson jsonObject = unsafeFunction "json_object" -- | Builds a binary JSON object out of a text array.@@ -249,24 +251,24 @@ -- which are taken as a key/value pair. jsonbObject :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))- :--> null 'PGjsonb+ --> null 'PGjsonb jsonbObject = unsafeFunction "jsonb_object" -- | This is an alternate form of 'jsonObject' that takes two arrays; one for -- keys and one for values, that are zipped pairwise to create a JSON object.-jsonZipObject :: FunctionN+jsonZipObject :: '[ null ('PGvararray ('NotNull 'PGtext)) , null ('PGvararray ('NotNull 'PGtext)) ]- ( null 'PGjson )+ ---> null 'PGjson jsonZipObject = unsafeFunctionN "json_object" -- | This is an alternate form of 'jsonbObject' that takes two arrays; one for -- keys and one for values, that are zipped pairwise to create a binary JSON -- object.-jsonbZipObject :: FunctionN+jsonbZipObject :: '[ null ('PGvararray ('NotNull 'PGtext)) , null ('PGvararray ('NotNull 'PGtext)) ]- ( null 'PGjsonb )+ ---> null 'PGjsonb jsonbZipObject = unsafeFunctionN "jsonb_object" {-----------------------------------------@@ -274,31 +276,31 @@ -----------------------------------------} -- | Returns the number of elements in the outermost JSON array.-jsonArrayLength :: null 'PGjson :--> null 'PGint4+jsonArrayLength :: null 'PGjson --> null 'PGint4 jsonArrayLength = unsafeFunction "json_array_length" -- | Returns the number of elements in the outermost binary JSON array.-jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4 jsonbArrayLength = unsafeFunction "jsonb_array_length" -- | Returns the type of the outermost JSON value as a text string. Possible -- types are object, array, string, number, boolean, and null.-jsonTypeof :: null 'PGjson :--> null 'PGtext+jsonTypeof :: null 'PGjson --> null 'PGtext jsonTypeof = unsafeFunction "json_typeof" -- | Returns the type of the outermost binary JSON value as a text string. -- Possible types are object, array, string, number, boolean, and null.-jsonbTypeof :: null 'PGjsonb :--> null 'PGtext+jsonbTypeof :: null 'PGjsonb --> null 'PGtext jsonbTypeof = unsafeFunction "jsonb_typeof" -- | Returns its argument with all object fields that have null values omitted. -- Other null values are untouched.-jsonStripNulls :: null 'PGjson :--> null 'PGjson+jsonStripNulls :: null 'PGjson --> null 'PGjson jsonStripNulls = unsafeFunction "json_strip_nulls" -- | Returns its argument with all object fields that have null values omitted. -- Other null values are untouched.-jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb jsonbStripNulls = unsafeFunction "jsonb_strip_nulls" -- | @ jsonbSet target path new_value create_missing @@@ -309,12 +311,9 @@ -- item designated by path does not exist. As with the path orientated -- operators, negative integers that appear in path count from the end of JSON -- arrays.-jsonbSet- :: FunctionN- '[ null 'PGjsonb- , null ('PGvararray ('NotNull 'PGtext))- , null 'PGjsonb- , null 'PGbool ] (null 'PGjsonb)+jsonbSet ::+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb jsonbSet = unsafeFunctionN "jsonbSet" -- | @ jsonbInsert target path new_value insert_after @@@ -326,86 +325,102 @@ -- path is in JSONB object, @new_value@ will be inserted only if target does not -- exist. As with the path orientated operators, negative integers that appear -- in path count from the end of JSON arrays.-jsonbInsert- :: FunctionN- '[ null 'PGjsonb- , null ('PGvararray ('NotNull 'PGtext))- , null 'PGjsonb- , null 'PGbool ] (null 'PGjsonb)+jsonbInsert ::+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb jsonbInsert = unsafeFunctionN "jsonb_insert" -- | Returns its argument as indented JSON text.-jsonbPretty :: null 'PGjsonb :--> null 'PGtext+jsonbPretty :: null 'PGjsonb --> null 'PGtext jsonbPretty = unsafeFunction "jsonb_pretty" - {- | Expands the outermost JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))-SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))+>>> printSQL (select Star (from (jsonEach (inline (Json (object ["a" .= "foo"]))))))+SELECT * FROM json_each(('{"a":"foo"}' :: json)) -}-jsonEach :: SetOfFunction "json_each" (null 'PGjson)- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]-jsonEach = unsafeSetOfFunction+jsonEach :: null 'PGjson -|->+ ("json_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson])+jsonEach = unsafeSetFunction "json_each" {- | Expands the outermost binary JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))-SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))+>>> printSQL (select Star (from (jsonbEach (inline (Jsonb (object ["a" .= "foo"]))))))+SELECT * FROM jsonb_each(('{"a":"foo"}' :: jsonb)) -} jsonbEach- :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]-jsonbEach = unsafeSetOfFunction+ :: null 'PGjsonb -|->+ ("jsonb_each" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson])+jsonbEach = unsafeSetFunction "jsonb_each" {- | Expands the outermost JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))-SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))+>>> printSQL (select Star (from (jsonEachText (inline (Json (object ["a" .= "foo"]))))))+SELECT * FROM json_each_text(('{"a":"foo"}' :: json)) -} jsonEachText- :: SetOfFunction "json_each_text" (null 'PGjson)- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]-jsonEachText = unsafeSetOfFunction+ :: null 'PGjson -|->+ ("json_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext])+jsonEachText = unsafeSetFunction "json_each_text" +{- | Returns a set of text values from a JSON array++>>> printSQL (select Star (from (jsonArrayElementsText (inline (Json (toJSON ["monkey", "pony", "bear"] ))))))+SELECT * FROM json_array_elements_text(('["monkey","pony","bear"]' :: json))+-}+jsonArrayElementsText+ :: null 'PGjson -|->+ ("json_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext])+jsonArrayElementsText = unsafeSetFunction "json_array_elements_text"+ {- | Expands the outermost binary JSON object into a set of key/value pairs. ->>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))-SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))+>>> printSQL (select Star (from (jsonbEachText (inline (Jsonb (object ["a" .= "foo"]))))))+SELECT * FROM jsonb_each_text(('{"a":"foo"}' :: jsonb)) -} jsonbEachText- :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)- '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]-jsonbEachText = unsafeSetOfFunction+ :: null 'PGjsonb -|->+ ("jsonb_each_text" ::: '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext])+jsonbEachText = unsafeSetFunction "jsonb_each_text" {- | Returns set of keys in the outermost JSON object. ->>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))-json_object_keys(('{"a":"foo","b":"bar"}' :: json))+>>> printSQL (jsonObjectKeys (inline (Json (object ["a" .= "foo"]))))+json_object_keys(('{"a":"foo"}' :: json)) -} jsonObjectKeys- :: SetOfFunction "json_object_keys" (nullity 'PGjson)- '["json_object_keys" ::: 'NotNull 'PGtext]-jsonObjectKeys = unsafeSetOfFunction+ :: null 'PGjson -|->+ ("json_object_keys" ::: '["json_object_keys" ::: 'NotNull 'PGtext])+jsonObjectKeys = unsafeSetFunction "json_object_keys" {- | Returns set of keys in the outermost JSON object. ->>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))-jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))+>>> printSQL (jsonbObjectKeys (inline (Jsonb (object ["a" .= "foo"]))))+jsonb_object_keys(('{"a":"foo"}' :: jsonb)) -} jsonbObjectKeys- :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)- '["jsonb_object_keys" ::: 'NotNull 'PGtext]-jsonbObjectKeys = unsafeSetOfFunction+ :: null 'PGjsonb -|->+ ("jsonb_object_keys" ::: '["jsonb_object_keys" ::: 'NotNull 'PGtext])+jsonbObjectKeys = unsafeSetFunction "jsonb_object_keys" +{- | Returns a set of text values from a binary JSON array++>>> printSQL (select Star (from (jsonbArrayElementsText (inline (Jsonb (toJSON ["red", "green", "cyan"] ))))))+SELECT * FROM jsonb_array_elements_text(('["red","green","cyan"]' :: jsonb))+-}+jsonbArrayElementsText+ :: null 'PGjsonb -|->+ ("jsonb_array_elements_text" ::: '["value" ::: 'NotNull 'PGtext])+jsonbArrayElementsText = unsafeSetFunction "jsonb_array_elements_text"+ -- | Build rows from Json types. type JsonPopulateFunction fun json- = forall schemas row outer commons params+ = forall db row lat with params . json `In` PGJsonType- => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type- -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)+ => TypeExpression db ('NotNull ('PGcomposite row)) -- ^ row type+ -> Expression 'Ungrouped lat with db params '[] ('NotNull json) -- ^ json type- -> FromClause outer commons schemas params '[fun ::: row]+ -> FromClause lat with db params '[fun ::: row] unsafePopulateFunction :: forall fun ty@@ -436,20 +451,20 @@ -- | Build rows from Json types. type JsonToRecordFunction json- = forall outer commons schemas params tab row+ = forall lat with db params tab row . (SOP.SListI row, json `In` PGJsonType)- => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)+ => Expression 'Ungrouped lat with db params '[] ('NotNull json) -- ^ json type- -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)+ -> Aliased (NP (Aliased (TypeExpression db))) (tab ::: row) -- ^ row type- -> FromClause outer commons schemas params '[tab ::: row]+ -> FromClause lat with db params '[tab ::: row] unsafeRecordFunction :: ByteString -> JsonToRecordFunction json unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $ fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab <> parenthesized (renderCommaSeparated renderTy types) where- renderTy :: Aliased (TypeExpression schemas) ty -> ByteString+ renderTy :: Aliased (TypeExpression db) ty -> ByteString renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty -- | Builds an arbitrary record from a JSON object.
− src/Squeal/PostgreSQL/Expression/Literal.hs
@@ -1,87 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Expression.Literal-Description: Literal expressions-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--Literal expressions--}--{-# LANGUAGE- FlexibleContexts- , FlexibleInstances- , LambdaCase- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeSynonymInstances- , UndecidableInstances-#-}--module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where--import ByteString.StrictBuilder (builderBytes)-import Data.ByteString.Lazy (toStrict)-import Data.Int-import Data.String-import Data.Text (Text)--import qualified Data.Aeson as JSON-import qualified Data.Text as Text-import qualified Data.Text.Lazy as Lazy (Text)-import qualified Data.Text.Lazy as Lazy.Text--import Squeal.PostgreSQL.Binary-import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Expression.Logic-import Squeal.PostgreSQL.PG-import Squeal.PostgreSQL.Render--{- |-The `Literal` class allows embedding a Haskell value directly-as an `Expression` using `literal`.-->>> printSQL (literal 'a')-E'a'-->>> printSQL (literal (1 :: Double))-1.0-->>> printSQL (literal (Json [1 :: Double, 2]))-('[1.0,2.0]' :: json)-->>> printSQL (literal (Enumerated GT))-'GT'--}-class Literal hask where literal :: hask -> Expr (null (PG hask))-instance Literal Bool where- literal = \case- True -> true- False -> false-instance JSON.ToJSON hask => Literal (Json hask) where- literal = UnsafeExpression . parenthesized . (<> " :: json")- . singleQuotedUtf8 . toStrict . JSON.encode . getJson-instance JSON.ToJSON hask => Literal (Jsonb hask) where- literal = UnsafeExpression . parenthesized . (<> " :: jsonb")- . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb-instance Literal Char where- literal chr = UnsafeExpression $- "E\'" <> fromString (escape chr) <> "\'"-instance Literal String where literal = fromString-instance Literal Int16 where literal = fromIntegral-instance Literal Int32 where literal = fromIntegral-instance Literal Int64 where literal = fromIntegral-instance Literal Float where literal = fromRational . toRational-instance Literal Double where literal = fromRational . toRational-instance Literal Text where literal = fromString . Text.unpack-instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack-instance ToParam (Enumerated enum) (PG (Enumerated enum))- => Literal (Enumerated enum) where- literal- = UnsafeExpression- . singleQuotedUtf8- . builderBytes- . unK- . toParam @(Enumerated enum) @(PG (Enumerated enum))
src/Squeal/PostgreSQL/Expression/Logic.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Logic-Description: Logical expressions+Description: logical expressions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Logical expressions and operators+logical expressions and operators -} {-# LANGUAGE@@ -15,25 +15,28 @@ #-} module Squeal.PostgreSQL.Expression.Logic- ( Condition+ ( -- * Condition+ Condition , true , false+ -- * Logic , not_ , (.&&) , (.||)+ -- * Conditional , caseWhenThenElse , ifThenElse ) where import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- | A `Condition` is an `Expression`, which can evaluate -- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses -- a three valued logic.-type Condition outer commons grp schemas params from =- Expression outer commons grp schemas params from ('Null 'PGbool)+type Condition grp lat with db params from =+ Expression grp lat with db params from ('Null 'PGbool) -- | >>> printSQL true -- TRUE@@ -47,8 +50,8 @@ -- | >>> printSQL $ not_ true -- (NOT TRUE)-not_ :: null 'PGbool :--> null 'PGbool-not_ = unsafeUnaryOpL "NOT"+not_ :: null 'PGbool --> null 'PGbool+not_ = unsafeLeftOp "NOT" -- | >>> printSQL $ true .&& false -- (TRUE AND FALSE)@@ -64,19 +67,19 @@ -- | >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3 -- in printSQL expression -- :}--- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END+-- CASE WHEN TRUE THEN (1 :: int2) WHEN FALSE THEN (2 :: int2) ELSE (3 :: int2) END caseWhenThenElse- :: [ ( Condition outer commons grp schemas params from- , Expression outer commons grp schemas params from ty+ :: [ ( Condition grp lat with db params from+ , Expression grp lat with db params from ty ) ] -- ^ whens and thens- -> Expression outer commons grp schemas params from ty+ -> Expression grp lat with db params from ty -- ^ else- -> Expression outer commons grp schemas params from ty+ -> Expression grp lat with db params from ty caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat [ "CASE" , mconcat@@ -92,14 +95,14 @@ -- | >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = ifThenElse true 1 0 -- in printSQL expression -- :}--- CASE WHEN TRUE THEN 1 ELSE 0 END+-- CASE WHEN TRUE THEN (1 :: int2) ELSE (0 :: int2) END ifThenElse- :: Condition outer commons grp schemas params from- -> Expression outer commons grp schemas params from ty -- ^ then- -> Expression outer commons grp schemas params from ty -- ^ else- -> Expression outer commons grp schemas params from ty+ :: Condition grp lat with db params from+ -> Expression grp lat with db params from ty -- ^ then+ -> Expression grp lat with db params from ty -- ^ else+ -> Expression grp lat with db params from ty ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
src/Squeal/PostgreSQL/Expression/Math.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Math-Description: Math expressions+Description: math functions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Mathematical functions and operators+math functions -} {-# LANGUAGE@@ -15,7 +15,8 @@ #-} module Squeal.PostgreSQL.Expression.Math- ( atan2_+ ( -- * Math Function+ atan2_ , quot_ , rem_ , trunc@@ -24,8 +25,8 @@ ) where import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -36,10 +37,8 @@ -- expression = atan2_ (pi *: 2) -- in printSQL expression -- :}--- atan2(pi(), 2)-atan2_- :: float `In` PGFloating- => FunctionN '[ null float, null float] (null float)+-- atan2(pi(), (2.0 :: float4))+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float atan2_ = unsafeFunctionN "atan2" @@ -47,11 +46,11 @@ -- -- >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = 5 `quot_` 2 -- in printSQL expression -- :}--- (5 / 2)+-- ((5 :: int2) / (2 :: int2)) quot_ :: int `In` PGIntegral => Operator (null int) (null int) (null int)@@ -61,11 +60,11 @@ -- -- >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGint2)+-- expression :: Expression grp lat with db params from (null 'PGint2) -- expression = 5 `rem_` 2 -- in printSQL expression -- :}--- (5 % 2)+-- ((5 :: int2) % (2 :: int2)) rem_ :: int `In` PGIntegral => Operator (null int) (null int) (null int)@@ -73,30 +72,30 @@ -- | >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)+-- expression :: Expression grp lat with db params from (null 'PGfloat4) -- expression = trunc pi -- in printSQL expression -- :} -- trunc(pi())-trunc :: frac `In` PGFloating => null frac :--> null frac+trunc :: frac `In` PGFloating => null frac --> null frac trunc = unsafeFunction "trunc" -- | >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)+-- expression :: Expression grp lat with db params from (null 'PGfloat4) -- expression = round_ pi -- in printSQL expression -- :} -- round(pi())-round_ :: frac `In` PGFloating => null frac :--> null frac+round_ :: frac `In` PGFloating => null frac --> null frac round_ = unsafeFunction "round" -- | >>> :{ -- let--- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)+-- expression :: Expression grp lat with db params from (null 'PGfloat4) -- expression = ceiling_ pi -- in printSQL expression -- :} -- ceiling(pi())-ceiling_ :: frac `In` PGFloating => null frac :--> null frac+ceiling_ :: frac `In` PGFloating => null frac --> null frac ceiling_ = unsafeFunction "ceiling"
src/Squeal/PostgreSQL/Expression/Null.hs view
@@ -1,34 +1,43 @@ {-| Module: Squeal.PostgreSQL.Expression.Null-Description: Null+Description: null expressions and handlers Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Null values and null handling functions+null expressions and handlers -} {-# LANGUAGE DataKinds+ , KindSignatures , OverloadedStrings+ , RankNTypes+ , TypeFamilies , TypeOperators #-} module Squeal.PostgreSQL.Expression.Null- ( null_- , notNull+ ( -- * Null+ null_+ , just_+ , unsafeNotNull+ , monoNotNull , coalesce , fromNull , isNull , isNotNull , matchNull , nullIf+ , CombineNullity+ -- deprecated+ , notNull ) where import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -42,16 +51,37 @@ -- | analagous to `Just` ----- >>> printSQL $ notNull true+-- >>> printSQL $ just_ true -- TRUE-notNull :: 'NotNull ty :--> 'Null ty+just_ :: 'NotNull ty --> 'Null ty+just_ = UnsafeExpression . renderSQL++-- | analagous to `Just`+{-# DEPRECATED notNull "use just_ instead" #-}+notNull :: 'NotNull ty --> 'Null ty notNull = UnsafeExpression . renderSQL +-- | Analagous to `Data.Maybe.fromJust` inverse to `notNull`,+-- useful when you know an `Expression` is `NotNull`,+-- because, for instance, you've filtered out @NULL@+-- values in a column.+unsafeNotNull :: 'Null ty --> 'NotNull ty+unsafeNotNull = UnsafeExpression . renderSQL++-- | Some expressions are null polymorphic which may raise+-- inference issues. Use `monoNotNull` to fix their+-- nullity as `NotNull`.+monoNotNull+ :: (forall null. Expression grp lat with db params from (null ty))+ -- ^ null polymorphic+ -> Expression grp lat with db params from ('NotNull ty)+monoNotNull x = x+ -- | return the leftmost value which is not NULL -- -- >>> printSQL $ coalesce [null_, true] false -- COALESCE(NULL, TRUE, FALSE)-coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)+coalesce :: FunctionVar ('Null ty) (null ty) (null ty) coalesce nullxs notNullx = UnsafeExpression $ "COALESCE" <> parenthesized (commaSeparated ((renderSQL <$> nullxs) <> [renderSQL notNullx]))@@ -61,20 +91,20 @@ -- >>> printSQL $ fromNull true null_ -- COALESCE(NULL, TRUE) fromNull- :: Expression outer commons grp schemas params from ('NotNull ty)+ :: Expression grp lat with db params from ('NotNull ty) -- ^ what to convert @NULL@ to- -> Expression outer commons grp schemas params from ('Null ty)- -> Expression outer commons grp schemas params from ('NotNull ty)+ -> Expression grp lat with db params from ('Null ty)+ -> Expression grp lat with db params from ('NotNull ty) fromNull notNullx nullx = coalesce [nullx] notNullx -- | >>> printSQL $ null_ & isNull -- NULL IS NULL-isNull :: 'Null ty :--> null 'PGbool+isNull :: 'Null ty --> null 'PGbool isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL" -- | >>> printSQL $ null_ & isNotNull -- NULL IS NOT NULL-isNotNull :: 'Null ty :--> null 'PGbool+isNotNull :: 'Null ty --> null 'PGbool isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL" -- | analagous to `maybe` using @IS NULL@@@ -82,23 +112,30 @@ -- >>> printSQL $ matchNull true not_ null_ -- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END matchNull- :: Expression outer commons grp schemas params from (nullty)+ :: Expression grp lat with db params from (nullty) -- ^ what to convert @NULL@ to- -> ( Expression outer commons grp schemas params from ('NotNull ty)- -> Expression outer commons grp schemas params from (nullty) )+ -> ( Expression grp lat with db params from ('NotNull ty)+ -> Expression grp lat with db params from (nullty) ) -- ^ function to perform when @NULL@ is absent- -> Expression outer commons grp schemas params from ('Null ty)- -> Expression outer commons grp schemas params from (nullty)+ -> Expression grp lat with db params from ('Null ty)+ -> Expression grp lat with db params from (nullty) matchNull y f x = ifThenElse (isNull x) y (f (UnsafeExpression (renderSQL x))) {-| right inverse to `fromNull`, if its arguments are equal then `nullIf` gives @NULL@. ->>> :set -XTypeApplications -XDataKinds->>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)->>> printSQL expr+>>> :set -XTypeApplications+>>> printSQL (nullIf (false *: param @1)) NULLIF(FALSE, ($1 :: bool)) -}-nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty nullIf = unsafeFunctionN "NULLIF"++{-| Make the return type of the type family `NotNull` if both arguments are,+ or `Null` otherwise.+-}+type family CombineNullity+ (lhs :: PGType -> NullType) (rhs :: PGType -> NullType) :: PGType -> NullType where+ CombineNullity 'NotNull 'NotNull = 'NotNull+ CombineNullity _ _ = 'Null
src/Squeal/PostgreSQL/Expression/Parameter.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Parameter-Description: Parameters+Description: out-of-line parameters Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Parameters, out-of-line data values+out-of-line parameters -} {-# LANGUAGE@@ -14,67 +14,120 @@ , FlexibleContexts , FlexibleInstances , FunctionalDependencies+ , GADTs , KindSignatures , MultiParamTypeClasses , OverloadedStrings , RankNTypes , ScopedTypeVariables , TypeApplications+ , TypeFamilies , TypeOperators , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Parameter- ( HasParameter (parameter)+ ( -- * Parameter+ HasParameter (parameter) , param+ -- * Parameter Internals+ , HasParameter'+ , ParamOutOfBoundsError+ , ParamTypeMismatchError ) where +import Data.Kind (Constraint)+import GHC.Exts (Any) import GHC.TypeLits import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Type import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL {- | A `HasParameter` constraint is used to indicate a value that is supplied externally to a SQL statement.-`Squeal.PostgreSQL.PQ.manipulateParams`,-`Squeal.PostgreSQL.PQ.queryParams` and-`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values+`Squeal.PostgreSQL.Session.manipulateParams`,+`Squeal.PostgreSQL.Session.queryParams` and+`Squeal.PostgreSQL.Session.traversePrepared` support specifying data values separately from the SQL command string, in which case `param`s are used to refer to the out-of-line data values. -}-class KnownNat n => HasParameter- (n :: Nat)- (params :: [NullityType])- (ty :: NullityType)- | n params -> ty where+class KnownNat ix => HasParameter+ (ix :: Nat)+ (params :: [NullType])+ (ty :: NullType)+ | ix params -> ty where -- | `parameter` takes a `Nat` using type application and a `TypeExpression`. --- -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)- -- >>> printSQL expr+ -- >>> printSQL (parameter @1 int4) -- ($1 :: int4) parameter- :: TypeExpression schemas ty- -> Expression outer commons grp schemas params from ty+ :: TypeExpression db ty+ -> Expression grp lat with db params from ty parameter ty = UnsafeExpression $ parenthesized $- "$" <> renderNat @n <+> "::"+ "$" <> renderNat @ix <+> "::" <+> renderSQL ty-instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1-instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)- => HasParameter n (ty' : params) ty +-- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating,+-- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@+instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x+instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x++-- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to+-- include the full parameter list in our errors.+class KnownNat ix => HasParameter'+ (originalIx :: Nat)+ (allParams :: [NullType])+ (ix :: Nat)+ (params :: [NullType])+ (ty :: NullType)+ | ix params -> ty where+instance {-# OVERLAPS #-}+ ( params ~ (y ': xs)+ , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError'+ , ParamOutOfBoundsError originalIx allParams params+ , ParamTypeMismatchError originalIx allParams x y+ ) => HasParameter' originalIx allParams 1 params x+instance {-# OVERLAPS #-}+ ( KnownNat ix+ , HasParameter' originalIx allParams (ix-1) xs x+ , params ~ (y ': xs)+ , ParamOutOfBoundsError originalIx allParams params+ )+ => HasParameter' originalIx allParams ix params x++-- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but+-- find a different field than we expected, or when we find ourself out of bounds+type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where+ ParamOutOfBoundsError originalIx allParams '[] = TypeError+ ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams)+ ParamOutOfBoundsError _ _ _ = ()++-- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but+-- find a different field than we expected, or when we find ourself out of bounds+type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where+ ParamTypeMismatchError _ _ found found = ()+ ParamTypeMismatchError originalIx allParams found expected = TypeError+ ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx+ ':$$: 'Text "in 1-indexed parameter list:"+ ':$$: 'Text " " ':<>: 'ShowType allParams+ ':$$: 'Text ""+ ':$$: 'Text "Expected: " ':<>: 'ShowType expected+ ':$$: 'Text "But found: " ':<>: 'ShowType found+ ':$$: 'Text ""+ )+ -- | `param` takes a `Nat` using type application and for basic types, -- infers a `TypeExpression`. ----- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)--- >>> printSQL expr+-- >>> printSQL (param @1 @('Null 'PGint4)) -- ($1 :: int4) param- :: forall n outer commons schemas params from grp ty- . (PGTyped schemas ty, HasParameter n params ty)- => Expression outer commons grp schemas params from ty -- ^ param-param = parameter @n (pgtype @schemas)+ :: forall n ty lat with db params from grp+ . (NullTyped db ty, HasParameter n params ty)+ => Expression grp lat with db params from ty -- ^ param+param = parameter @n (nulltype @db)
+ src/Squeal/PostgreSQL/Expression/Range.hs view
@@ -0,0 +1,227 @@+{-|+Module: Squeal.PostgreSQL.Expression.Range+Description: range types and functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++range types and functions+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DeriveFoldable+ , DerivingStrategies+ , DeriveTraversable+ , FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , PatternSynonyms+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Expression.Range+ ( -- * Range+ Range (..)+ , (<=..<=), (<..<), (<=..<), (<..<=)+ , moreThan, atLeast, lessThan, atMost+ , singleton, whole+ , Bound (..)+ -- * Range Function+ -- ** Range Construction+ , range+ -- ** Range Operator+ , (.<@)+ , (@>.)+ , (<<@)+ , (@>>)+ , (&<)+ , (&>)+ , (-|-)+ , (@+)+ , (@*)+ , (@-)+ -- ** Range Function+ , lowerBound+ , upperBound+ , isEmpty+ , lowerInc+ , lowerInf+ , upperInc+ , upperInf+ , rangeMerge+ ) where++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Type hiding (bool)+import Squeal.PostgreSQL.Type.PG+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL (tstzrange, numrange, int4range, now, printSQL)++-- | Construct a `range`+--+-- >>> printSQL $ range tstzrange (atLeast now)+-- tstzrange(now(), NULL, '[)')+-- >>> printSQL $ range numrange (0 <=..< 2*pi)+-- numrange((0.0 :: numeric), ((2.0 :: numeric) * pi()), '[)')+-- >>> printSQL $ range int4range Empty+-- ('empty' :: int4range)+range+ :: TypeExpression db (null ('PGrange ty))+ -- ^ range type+ -> Range (Expression grp lat with db params from ('NotNull ty))+ -- ^ range of values+ -> Expression grp lat with db params from (null ('PGrange ty))+range ty = \case+ Empty -> UnsafeExpression $ parenthesized+ (emp <+> "::" <+> renderSQL ty)+ NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized+ (commaSeparated (args l u))+ where+ emp = singleQuote <> "empty" <> singleQuote+ args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]+ singleQuote = "\'"+ arg = \case+ Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x+ bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("+ ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"++-- | The type of `Bound` for a `Range`.+data Bound x+ = Infinite -- ^ unbounded+ | Closed x -- ^ inclusive+ | Open x -- ^ exclusive+ deriving+ ( Eq, Ord, Show, Read, GHC.Generic+ , Functor, Foldable, Traversable )++-- | A `Range` datatype that comprises connected subsets of+-- the real line.+data Range x = Empty | NonEmpty (Bound x) (Bound x)+ deriving+ ( Eq, Ord, Show, Read, GHC.Generic+ , Functor, Foldable, Traversable )+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+-- | `PGrange` @(@`PG` @hask)@+instance IsPG hask => IsPG (Range hask) where+ type PG (Range hask) = 'PGrange (PG hask)++-- | Finite `Range` constructor+(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x+infix 4 <=..<=, <..<, <=..<, <..<=+x <=..<= y = NonEmpty (Closed x) (Closed y)+x <..< y = NonEmpty (Open x) (Open y)+x <=..< y = NonEmpty (Closed x) (Open y)+x <..<= y = NonEmpty (Open x) (Closed y)++-- | Half-infinite `Range` constructor+moreThan, atLeast, lessThan, atMost :: x -> Range x+moreThan x = NonEmpty (Open x) Infinite+atLeast x = NonEmpty (Closed x) Infinite+lessThan x = NonEmpty Infinite (Open x)+atMost x = NonEmpty Infinite (Closed x)++-- | A point on the line+singleton :: x -> Range x+singleton x = x <=..<= x++-- | The `whole` line+whole :: Range x+whole = NonEmpty Infinite Infinite++-- | range is contained by+(.<@) :: Operator (null0 ty) (null1 ('PGrange ty)) ('Null 'PGbool)+(.<@) = unsafeBinaryOp "<@"++-- | contains range+(@>.) :: Operator (null0 ('PGrange ty)) (null1 ty) ('Null 'PGbool)+(@>.) = unsafeBinaryOp "@>"++-- | strictly left of,+-- return false when an empty range is involved+(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)+(<<@) = unsafeBinaryOp "<<"++-- | strictly right of,+-- return false when an empty range is involved+(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)+(@>>) = unsafeBinaryOp ">>"++-- | does not extend to the right of,+-- return false when an empty range is involved+(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)+(&<) = unsafeBinaryOp "&<"++-- | does not extend to the left of,+-- return false when an empty range is involved+(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)+(&>) = unsafeBinaryOp "&>"++-- | is adjacent to, return false when an empty range is involved+(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)+(-|-) = unsafeBinaryOp "-|-"++-- | union, will fail if the resulting range would+-- need to contain two disjoint sub-ranges+(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))+(@+) = unsafeBinaryOp "+"++-- | intersection+(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))+(@*) = unsafeBinaryOp "*"++-- | difference, will fail if the resulting range would+-- need to contain two disjoint sub-ranges+(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))+(@-) = unsafeBinaryOp "-"++-- | lower bound of range+lowerBound :: null ('PGrange ty) --> 'Null ty+lowerBound = unsafeFunction "lower"++-- | upper bound of range+upperBound :: null ('PGrange ty) --> 'Null ty+upperBound = unsafeFunction "upper"++-- | is the range empty?+isEmpty :: null ('PGrange ty) --> 'Null 'PGbool+isEmpty = unsafeFunction "isempty"++-- | is the lower bound inclusive?+lowerInc :: null ('PGrange ty) --> 'Null 'PGbool+lowerInc = unsafeFunction "lower_inc"++-- | is the lower bound infinite?+lowerInf :: null ('PGrange ty) --> 'Null 'PGbool+lowerInf = unsafeFunction "lower_inf"++-- | is the upper bound inclusive?+upperInc :: null ('PGrange ty) --> 'Null 'PGbool+upperInc = unsafeFunction "upper_inc"++-- | is the upper bound infinite?+upperInf :: null ('PGrange ty) --> 'Null 'PGbool+upperInf = unsafeFunction "upper_inf"++-- | the smallest range which includes both of the given ranges+rangeMerge ::+ '[null ('PGrange ty), null ('PGrange ty)]+ ---> null ('PGrange ty)+rangeMerge = unsafeFunctionN "range_merge"
− src/Squeal/PostgreSQL/Expression/SetOf.hs
@@ -1,106 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Expression.SetOf-Description: Set returning functions-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--Set returning functions--}--{-# LANGUAGE- AllowAmbiguousTypes- , DataKinds- , FlexibleContexts- , OverloadedStrings- , PolyKinds- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeOperators-#-}--module Squeal.PostgreSQL.Expression.SetOf- ( generateSeries- , generateSeriesStep- , generateSeriesTimestamp- , SetOfFunction- , unsafeSetOfFunction- , SetOfFunctionN- , unsafeSetOfFunctionN- ) where--import GHC.TypeLits--import qualified Generics.SOP as SOP--import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Query-import Squeal.PostgreSQL.Schema--{- |-A @RankNType@ for set returning functions with 1 argument.--}-type SetOfFunction fun ty setof- = forall outer commons schemas params- . Expression outer commons 'Ungrouped schemas params '[] ty- -- ^ input- -> FromClause outer commons schemas params '[fun ::: setof]- -- ^ output---- | Escape hatch for a set returning function with 1 argument.-unsafeSetOfFunction- :: forall fun ty setof. KnownSymbol fun- => SetOfFunction fun ty setof -- ^ set returning function-unsafeSetOfFunction x = UnsafeFromClause $- renderSymbol @fun <> parenthesized (renderSQL x)--{- |-A @RankNType@ for set returning functions with multiple argument.--}-type SetOfFunctionN fun tys setof- = forall outer commons schemas params- . NP (Expression outer commons 'Ungrouped schemas params '[]) tys- -- ^ inputs- -> FromClause outer commons schemas params '[fun ::: setof]- -- ^ output---- | Escape hatch for a set returning function with multiple argument.-unsafeSetOfFunctionN- :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)- => SetOfFunctionN fun tys setof -- ^ set returning function-unsafeSetOfFunctionN xs = UnsafeFromClause $- renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)--{- | @generateSeries (start *: stop)@--Generate a series of values, from @start@ to @stop@ with a step size of one--}-generateSeries- :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]- => SetOfFunctionN "generate_series" '[ null ty, null ty]- '["generate_series" ::: null ty] -- ^ set returning function-generateSeries = unsafeSetOfFunctionN--{- | @generateSeries (start :* stop *: step)@--Generate a series of values, from @start@ to @stop@ with a step size of @step@--}-generateSeriesStep- :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]- => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]- '["generate_series" ::: null ty] -- ^ set returning function-generateSeriesStep = unsafeSetOfFunctionN--{- | @generateSeries (start :* stop *: step)@--Generate a series of values, from @start@ to @stop@ with a step size of @step@--}-generateSeriesTimestamp- :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]- => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]- '["generate_series" ::: null ty] -- ^ set returning function-generateSeriesTimestamp = unsafeSetOfFunctionN
src/Squeal/PostgreSQL/Expression/Sort.hs view
@@ -1,29 +1,33 @@ {-| Module: Squeal.PostgreSQL.Expression.Sort-Description: Sort expressions+Description: sort expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Sort expressions+sort expressions -} {-# LANGUAGE DataKinds+ , FlexibleInstances+ , FunctionalDependencies , GADTs , LambdaCase+ , MultiParamTypeClasses , OverloadedStrings , StandaloneDeriving #-} module Squeal.PostgreSQL.Expression.Sort- ( SortExpression (..)+ ( -- * Sort+ SortExpression (..) , OrderBy (..) ) where import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- | `SortExpression`s are used by `orderBy` to optionally sort the results -- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`@@ -36,27 +40,33 @@ -- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to -- determine whether nulls appear before or after non-null values in the sort -- ordering of a `Null` result column.-data SortExpression outer commons grp schemas params from where+data SortExpression grp lat with db params from where Asc- :: Expression outer commons grp schemas params from ('NotNull ty)- -> SortExpression outer commons grp schemas params from+ :: Expression grp lat with db params from ('NotNull ty)+ -- ^ sort by+ -> SortExpression grp lat with db params from Desc- :: Expression outer commons grp schemas params from ('NotNull ty)- -> SortExpression outer commons grp schemas params from+ :: Expression grp lat with db params from ('NotNull ty)+ -- ^ sort by+ -> SortExpression grp lat with db params from AscNullsFirst- :: Expression outer commons grp schemas params from ('Null ty)- -> SortExpression outer commons grp schemas params from+ :: Expression grp lat with db params from ('Null ty)+ -- ^ sort by+ -> SortExpression grp lat with db params from AscNullsLast- :: Expression outer commons grp schemas params from ('Null ty)- -> SortExpression outer commons grp schemas params from+ :: Expression grp lat with db params from ('Null ty)+ -- ^ sort by+ -> SortExpression grp lat with db params from DescNullsFirst- :: Expression outer commons grp schemas params from ('Null ty)- -> SortExpression outer commons grp schemas params from+ :: Expression grp lat with db params from ('Null ty)+ -- ^ sort by+ -> SortExpression grp lat with db params from DescNullsLast- :: Expression outer commons grp schemas params from ('Null ty)- -> SortExpression outer commons grp schemas params from-deriving instance Show (SortExpression outer commons grp schemas params from)-instance RenderSQL (SortExpression outer commons grp schemas params from) where+ :: Expression grp lat with db params from ('Null ty)+ -- ^ sort by+ -> SortExpression grp lat with db params from+deriving instance Show (SortExpression grp lat with db params from)+instance RenderSQL (SortExpression grp lat with db params from) where renderSQL = \case Asc expression -> renderSQL expression <+> "ASC" Desc expression -> renderSQL expression <+> "DESC"@@ -66,6 +76,11 @@ <+> "DESC NULLS FIRST" AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST" DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"+instance RenderSQL [SortExpression grp lat with db params from] where+ renderSQL = \case+ [] -> ""+ srts -> " ORDER BY"+ <+> commaSeparated (renderSQL <$> srts) {- | The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`@@ -78,8 +93,9 @@ You can also control the order in which rows are processed by window functions using `orderBy` within `Squeal.PostgreSQL.Query.Over`. -}-class OrderBy expr where+class OrderBy expr grp | expr -> grp where orderBy- :: [SortExpression outer commons grp schemas params from]- -> expr outer commons grp schemas params from- -> expr outer commons grp schemas params from+ :: [SortExpression grp lat with db params from]+ -- ^ sorts+ -> expr lat with db params from+ -> expr lat with db params from
src/Squeal/PostgreSQL/Expression/Subquery.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Subquery-Description: Subquery expressions+Description: subquery expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Subquery expressions+subquery expressions -} {-# LANGUAGE@@ -16,20 +16,21 @@ #-} module Squeal.PostgreSQL.Expression.Subquery- ( exists+ ( -- * Subquery+ exists , in_ , notIn , subAll , subAny ) where -import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic-import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Query import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -47,8 +48,9 @@ at least one row is returned, not all the way to completion. -} exists- :: Query (Join outer from) commons schemas params row- -> Condition outer commons grp schemas params from+ :: Query (Join lat from) with db params row+ -- ^ subquery+ -> Expression grp lat with db params from (null 'PGbool) exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query) {- |@@ -66,10 +68,10 @@ (TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo"))) -} subAll- :: Expression outer commons grp schemas params from ty1 -- ^ expression+ :: Expression grp lat with db params from ty1 -- ^ expression -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator- -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery- -> Condition outer commons grp schemas params from+ -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery+ -> Condition grp lat with db params from subAll expr (?) qry = expr ? (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry)) @@ -81,13 +83,13 @@ (including the case where the subquery returns no rows). >>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))-(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))+((E'foo' :: text) LIKE ANY (SELECT * FROM (VALUES ((E'foobar' :: text))) AS t ("foo"))) -} subAny- :: Expression outer commons grp schemas params from ty1 -- ^ expression+ :: Expression grp lat with db params from ty1 -- ^ expression -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator- -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery- -> Condition outer commons grp schemas params from+ -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery+ -> Condition grp lat with db params from subAny expr (?) qry = expr ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry)) @@ -99,9 +101,10 @@ TRUE IN (TRUE, FALSE, NULL) -} in_- :: Expression outer commons grp schemas params from ty -- ^ expression- -> [Expression outer commons grp schemas params from ty]- -> Condition outer commons grp schemas params from+ :: Expression grp lat with db params from ty -- ^ expression+ -> [Expression grp lat with db params from ty]+ -> Expression grp lat with db params from ('Null 'PGbool)+_ `in_` [] = false expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN" <+> parenthesized (commaSeparated (renderSQL <$> exprs)) @@ -113,8 +116,9 @@ TRUE NOT IN (FALSE, NULL) -} notIn- :: Expression outer commons grp schemas params from ty -- ^ expression- -> [Expression outer commons grp schemas params from ty]- -> Condition outer commons grp schemas params from+ :: Expression grp lat with db params from ty -- ^ expression+ -> [Expression grp lat with db params from ty]+ -> Expression grp lat with db params from ('Null 'PGbool)+_ `notIn` [] = true expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN" <+> parenthesized (commaSeparated (renderSQL <$> exprs))
src/Squeal/PostgreSQL/Expression/Text.hs view
@@ -1,46 +1,51 @@ {-| Module: Squeal.PostgreSQL.Expression.Text-Description: Text expressions+Description: text functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -String functions and operators+text functions and operators -} {-# LANGUAGE DataKinds , OverloadedStrings+ , RankNTypes+ , ScopedTypeVariables , TypeOperators #-} module Squeal.PostgreSQL.Expression.Text- ( lower+ ( -- * Text Function+ lower , upper , charLength , like , ilike+ , replace+ , strpos ) where import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL -- | >>> printSQL $ lower "ARRRGGG"--- lower(E'ARRRGGG')-lower :: null 'PGtext :--> null 'PGtext+-- lower((E'ARRRGGG' :: text))+lower :: null 'PGtext --> null 'PGtext lower = unsafeFunction "lower" -- | >>> printSQL $ upper "eeee"--- upper(E'eeee')-upper :: null 'PGtext :--> null 'PGtext+-- upper((E'eeee' :: text))+upper :: null 'PGtext --> null 'PGtext upper = unsafeFunction "upper" -- | >>> printSQL $ charLength "four"--- char_length(E'four')-charLength :: null 'PGtext :--> null 'PGint4+-- char_length((E'four' :: text))+charLength :: null 'PGtext --> null 'PGint4 charLength = unsafeFunction "char_length" -- | The `like` expression returns true if the @string@ matches@@ -51,7 +56,7 @@ -- matches any sequence of zero or more characters. -- -- >>> printSQL $ "abc" `like` "a%"--- (E'abc' LIKE E'a%')+-- ((E'abc' :: text) LIKE (E'a%' :: text)) like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) like = unsafeBinaryOp "LIKE" @@ -59,6 +64,25 @@ -- match case-insensitive according to the active locale. -- -- >>> printSQL $ "abc" `ilike` "a%"--- (E'abc' ILIKE E'a%')+-- ((E'abc' :: text) ILIKE (E'a%' :: text)) ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool) ilike = unsafeBinaryOp "ILIKE"++-- | Determines the location of the substring match using the `strpos`+-- function. Returns the 1-based index of the first match, if no+-- match exists the function returns (0).+--+-- >>> printSQL $ strpos ("string" *: "substring")+-- strpos((E'string' :: text), (E'substring' :: text))+strpos+ :: '[null 'PGtext, null 'PGtext] ---> null 'PGint4+strpos = unsafeFunctionN "strpos"++-- | Over the string in the first argument, replace all occurrences of+-- the second argument with the third and return the modified string.+--+-- >>> printSQL $ replace ("string" :* "from" *: "to")+-- replace((E'string' :: text), (E'from' :: text), (E'to' :: text))+replace+ :: '[ null 'PGtext, null 'PGtext, null 'PGtext ] ---> null 'PGtext+replace = unsafeFunctionN "replace"
src/Squeal/PostgreSQL/Expression/TextSearch.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.TextSearch-Description: Text search expressions+Description: text search functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Text search functions and operators+text search functions and operators -} {-# LANGUAGE@@ -15,11 +15,13 @@ #-} module Squeal.PostgreSQL.Expression.TextSearch- ( (@@)+ ( -- * Text Search Operator+ (@@) , (.&) , (.|) , (.!) , (<->)+ -- * Text Search Function , arrayToTSvector , tsvectorLength , numnode@@ -39,8 +41,8 @@ ) where import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema -- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ? (@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)@@ -55,8 +57,8 @@ (.|) = unsafeBinaryOp "||" -- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`-(.!) :: null 'PGtsquery :--> null 'PGtsquery-(.!) = unsafeUnaryOpL "!!"+(.!) :: null 'PGtsquery --> null 'PGtsquery+(.!) = unsafeLeftOp "!!" -- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by -- `Squeal.PostgreSQL.Expression.Type.tsquery`@@ -66,51 +68,50 @@ -- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector` arrayToTSvector :: null ('PGvararray ('NotNull 'PGtext))- :--> null 'PGtsvector+ --> null 'PGtsvector arrayToTSvector = unsafeFunction "array_to_tsvector" -- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`-tsvectorLength :: null 'PGtsvector :--> null 'PGint4+tsvectorLength :: null 'PGtsvector --> null 'PGint4 tsvectorLength = unsafeFunction "length" -- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`-numnode :: null 'PGtsquery :--> null 'PGint4+numnode :: null 'PGtsquery --> null 'PGint4 numnode = unsafeFunction "numnode" -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation-plainToTSquery :: null 'PGtext :--> null 'PGtsquery+plainToTSquery :: null 'PGtext --> null 'PGtsquery plainToTSquery = unsafeFunction "plainto_tsquery" -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase, -- ignoring punctuation-phraseToTSquery :: null 'PGtext :--> null 'PGtsquery+phraseToTSquery :: null 'PGtext --> null 'PGtsquery phraseToTSquery = unsafeFunction "phraseto_tsquery" -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query-websearchToTSquery :: null 'PGtext :--> null 'PGtsquery+websearchToTSquery :: null 'PGtext --> null 'PGtsquery websearchToTSquery = unsafeFunction "websearch_to_tsquery" -- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`-queryTree :: null 'PGtsquery :--> null 'PGtext+queryTree :: null 'PGtsquery --> null 'PGtext queryTree = unsafeFunction "query_tree" -- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`-toTSquery :: null 'PGtext :--> null 'PGtsquery+toTSquery :: null 'PGtext --> null 'PGtsquery toTSquery = unsafeFunction "to_tsquery" -- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector` toTSvector :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]- => null ty :--> null 'PGtsvector+ => null ty --> null 'PGtsvector toTSvector = unsafeFunction "to_tsvector" -- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`-setWeight- :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector setWeight = unsafeFunctionN "set_weight" -- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`-strip :: null 'PGtsvector :--> null 'PGtsvector+strip :: null 'PGtsvector --> null 'PGtsvector strip = unsafeFunction "strip" -- | @jsonToTSvector (document *: filter)@@@ -123,7 +124,7 @@ -- "boolean" (to include all Boolean values in the string format "true"/"false"), -- "key" (to include all keys) or "all" (to include all above). -- These values can be combined together to include, e.g. all string and numeric values.-jsonToTSvector :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector jsonToTSvector = unsafeFunctionN "json_to_tsvector" -- | @jsonbToTSvector (document *: filter)@@@ -136,23 +137,23 @@ -- "boolean" (to include all Boolean values in the string format "true"/"false"), -- "key" (to include all keys) or "all" (to include all above). -- These values can be combined together to include, e.g. all string and numeric values.-jsonbToTSvector :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector" -- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`-tsDelete :: FunctionN+tsDelete :: '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]- (null 'PGtsvector)+ ---> null 'PGtsvector tsDelete = unsafeFunctionN "ts_delete" -- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`-tsFilter :: FunctionN+tsFilter :: '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]- (null 'PGtsvector)+ ---> null 'PGtsvector tsFilter = unsafeFunctionN "ts_filter" -- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match tsHeadline :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]- => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)+ => '[null document, null 'PGtsquery] ---> null 'PGtext tsHeadline = unsafeFunctionN "ts_headline"
src/Squeal/PostgreSQL/Expression/Time.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Expression.Time-Description: Date/Time expressions+Description: date/time functions and operators Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Date/Time functions and operators+date/time functions and operators -} {-# LANGUAGE@@ -17,13 +17,19 @@ , OverloadedStrings , PolyKinds , RankNTypes+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Time- ( TimeOp (..)+ ( -- * Time Operation+ TimeOp (..)+ -- * Time Function , currentDate , currentTime , currentTimestamp+ , dateTrunc , localTime , localTimestamp , now@@ -31,18 +37,24 @@ , makeTime , makeTimestamp , makeTimestamptz+ , atTimeZone+ , PGAtTimeZone+ -- * Interval , interval_ , TimeUnit (..) ) where +import Data.Fixed import Data.String+import GHC.TypeLits import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -83,34 +95,29 @@ Create date from year, month and day fields >>> printSQL (makeDate (1984 :* 7 *: 3))-make_date(1984, 7, 3)+make_date((1984 :: int4), (7 :: int4), (3 :: int4)) -}-makeDate :: FunctionN- '[ null 'PGint4, null 'PGint4, null 'PGint4 ]- ( null 'PGdate )+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate makeDate = unsafeFunctionN "make_date" {-| Create time from hour, minute and seconds fields >>> printSQL (makeTime (8 :* 15 *: 23.5))-make_time(8, 15, 23.5)+make_time((8 :: int4), (15 :: int4), (23.5 :: float8)) -}-makeTime :: FunctionN- '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]- ( null 'PGtime )+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime makeTime = unsafeFunctionN "make_time" {-| Create timestamp from year, month, day, hour, minute and seconds fields >>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))-make_timestamp(2013, 7, 15, 8, 15, 23.5)+make_timestamp((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) -}-makeTimestamp :: FunctionN+makeTimestamp :: '[ null 'PGint4, null 'PGint4, null 'PGint4- , null 'PGint4, null 'PGint4, null 'PGfloat8 ]- ( null 'PGtimestamp )+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp makeTimestamp = unsafeFunctionN "make_timestamp" {-|@@ -119,39 +126,81 @@ the current time zone is used >>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))-make_timestamptz(2013, 7, 15, 8, 15, 23.5)+make_timestamptz((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8)) -}-makeTimestamptz :: FunctionN+makeTimestamptz :: '[ null 'PGint4, null 'PGint4, null 'PGint4- , null 'PGint4, null 'PGint4, null 'PGfloat8 ]- ( null 'PGtimestamptz )+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz makeTimestamptz = unsafeFunctionN "make_timestamptz" {-|+Truncate a timestamp with the specified precision++>>> printSQL $ dateTrunc Quarter (makeTimestamp (2010 :* 5 :* 6 :* 14 :* 45 *: 11.4))+date_trunc('quarter', make_timestamp((2010 :: int4), (5 :: int4), (6 :: int4), (14 :: int4), (45 :: int4), (11.4 :: float8)))+-}+dateTrunc+ :: time `In` '[ 'PGtimestamp, 'PGtimestamptz ]+ => TimeUnit -> null time --> null time+dateTrunc tUnit args = unsafeFunctionN "date_trunc" (timeUnitExpr *: args)+ where+ timeUnitExpr :: forall grp lat with db params from null0.+ Expression grp lat with db params from (null0 'PGtext)+ timeUnitExpr = UnsafeExpression . singleQuotedUtf8 . renderSQL $ tUnit++-- | Calculate the return time type of the `atTimeZone` `Operator`.+type family PGAtTimeZone ty where+ PGAtTimeZone 'PGtimestamptz = 'PGtimestamp+ PGAtTimeZone 'PGtimestamp = 'PGtimestamptz+ PGAtTimeZone 'PGtimetz = 'PGtimetz+ PGAtTimeZone pg = TypeError+ ( 'Text "Squeal type error: AT TIME ZONE cannot be applied to "+ ':<>: 'ShowType pg )++{-|+Convert a timestamp, timestamp with time zone, or time of day with timezone to a different timezone using an interval offset or specific timezone denoted by text. When using the interval offset, the interval duration must be less than one day or 24 hours.++>>> printSQL $ (makeTimestamp (2009 :* 7 :* 22 :* 19 :* 45 *: 11.4)) `atTimeZone` (interval_ 8 Hours)+(make_timestamp((2009 :: int4), (7 :: int4), (22 :: int4), (19 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (INTERVAL '8.000 hours'))++>>> :{+ let+ timezone :: Expr (null 'PGtext)+ timezone = "EST"+ in printSQL $ (makeTimestamptz (2015 :* 9 :* 15 :* 4 :* 45 *: 11.4)) `atTimeZone` timezone+:}+(make_timestamptz((2015 :: int4), (9 :: int4), (15 :: int4), (4 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (E'EST' :: text))+-}+atTimeZone+ :: zone `In` '[ 'PGtext, 'PGinterval]+ => Operator (null time) (null zone) (null (PGAtTimeZone time))+atTimeZone = unsafeBinaryOp "AT TIME ZONE"++{-| Affine space operations on time types. -} class TimeOp time diff | time -> diff where {-| >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)- (make_date(1984, 7, 3) + 365)+ (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) + (365 :: int4)) -} (!+) :: Operator (null time) (null diff) (null time) (!+) = unsafeBinaryOp "+" {-| >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))- (365 + make_date(1984, 7, 3))+ ((365 :: int4) + make_date((1984 :: int4), (7 :: int4), (3 :: int4))) -} (+!) :: Operator (null diff) (null time) (null time) (+!) = unsafeBinaryOp "+" {-| >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)- (make_date(1984, 7, 3) - 365)+ (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - (365 :: int4)) -} (!-) :: Operator (null time) (null diff) (null time) (!-) = unsafeBinaryOp "-" {-| >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)- (make_date(1984, 7, 3) - CURRENT_DATE)+ (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - CURRENT_DATE) -} (!-!) :: Operator (null time) (null time) (null diff) (!-!) = unsafeBinaryOp "-"@@ -168,7 +217,7 @@ -- | A `TimeUnit` to use in `interval_` construction. data TimeUnit- = Years | Months | Weeks | Days+ = Years | Quarter | Months | Weeks | Days | Hours | Minutes | Seconds | Microseconds | Milliseconds | Decades | Centuries | Millennia@@ -178,6 +227,7 @@ instance RenderSQL TimeUnit where renderSQL = \case Years -> "years"+ Quarter -> "quarter" Months -> "months" Weeks -> "weeks" Days -> "days"@@ -191,7 +241,7 @@ Millennia -> "millennia" -- | >>> printSQL $ interval_ 7 Days--- (INTERVAL '7.0 days')-interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)+-- (INTERVAL '7.000 days')+interval_ :: Milli -> TimeUnit -> Expr (null 'PGinterval) interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+> "'" <> fromString (show num) <+> renderSQL unit <> "'"
src/Squeal/PostgreSQL/Expression/Type.hs view
@@ -1,17 +1,18 @@ {-| Module: Squeal.PostgreSQL.Expression-Description: Type expressions+Description: type expressions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Type expressions.+type expressions -} {-# LANGUAGE AllowAmbiguousTypes , DataKinds , DeriveGeneric+ , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs@@ -23,14 +24,18 @@ , ScopedTypeVariables , TypeApplications , TypeOperators+ , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Type- ( TypeExpression (..)- , cast+ ( -- * Type Cast+ cast , astype , inferredtype- , PGTyped (..)+ -- * Type Expression+ , TypeExpression (..)+ , typerow+ , typeenum , typedef , typetable , typeview@@ -56,9 +61,11 @@ , bytea , timestamp , timestampWithTimeZone+ , timestamptz , date , time , timeWithTimeZone+ , timetz , interval , uuid , inet@@ -68,6 +75,33 @@ , fixarray , tsvector , tsquery+ , oid+ , int4range+ , int8range+ , numrange+ , tsrange+ , tstzrange+ , daterange+ , record+ -- * Column Type+ , ColumnTypeExpression (..)+ , nullable+ , notNullable+ , default_+ , serial2+ , smallserial+ , serial4+ , serial+ , serial8+ , bigserial+ -- * Type Inference+ , PGTyped (..)+ , pgtypeFrom+ , NullTyped (..)+ , nulltypeFrom+ , ColumnTyped (..)+ , columntypeFrom+ , FieldTyped (..) ) where import Control.DeepSeq@@ -79,10 +113,11 @@ import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP -import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -94,24 +129,24 @@ -- | >>> printSQL $ true & cast int4 -- (TRUE :: int4) cast- :: TypeExpression schemas ty1+ :: TypeExpression db ty1 -- ^ type to cast as- -> Expression outer commons grp schemas params from ty0+ -> Expression grp lat with db params from ty0 -- ^ value to convert- -> Expression outer commons grp schemas params from ty1+ -> Expression grp lat with db params from ty1 cast ty x = UnsafeExpression $ parenthesized $ renderSQL x <+> "::" <+> renderSQL ty -- | A safe version of `cast` which just matches a value with its type. -- -- >>> printSQL (1 & astype int)--- (1 :: int)+-- ((1 :: int4) :: int) astype- :: TypeExpression schemas ty+ :: TypeExpression db ty -- ^ type to specify as- -> Expression outer commons grp schemas params from ty+ -> Expression grp lat with db params from ty -- ^ value- -> Expression outer commons grp schemas params from ty+ -> Expression grp lat with db params from ty astype = cast -- | `inferredtype` will add a type annotation to an `Expression`@@ -120,10 +155,11 @@ -- >>> printSQL (inferredtype true) -- (TRUE :: bool) inferredtype- :: PGTyped schemas ty- => Expression outer common grp schemas params from ty- -> Expression outer common grp schemas params from ty-inferredtype = astype pgtype+ :: NullTyped db ty+ => Expression lat common grp db params from ty+ -- ^ value+ -> Expression lat common grp db params from ty+inferredtype = astype nulltype {----------------------------------------- type expressions@@ -131,127 +167,158 @@ -- | `TypeExpression`s are used in `cast`s and -- `Squeal.PostgreSQL.Definition.createTable` commands.-newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)+newtype TypeExpression (db :: SchemasType) (ty :: NullType) = UnsafeTypeExpression { renderTypeExpression :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (TypeExpression schemas ty) where+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (TypeExpression db ty) where renderSQL = renderTypeExpression +-- | The composite type corresponding to a relation can be expressed+-- by its alias. A relation is either a composite type, a table or a view.+-- It subsumes `typetable` and `typeview` and partly overlaps `typedef`.+typerow+ :: ( relss ~ DbRelations db+ , Has sch relss rels+ , Has rel rels row+ )+ => QualifiedAlias sch rel+ -- ^ type alias+ -> TypeExpression db (null ('PGcomposite row))+typerow = UnsafeTypeExpression . renderSQL++-- | An enumerated type can be expressed by its alias.+-- `typeenum` is subsumed by `typedef`.+typeenum+ :: ( enumss ~ DbEnums db+ , Has sch enumss enums+ , Has enum enums labels+ )+ => QualifiedAlias sch enum+ -- ^ type alias+ -> TypeExpression db (null ('PGenum labels))+typeenum = UnsafeTypeExpression . renderSQL+ -- | The enum or composite type in a `Typedef` can be expressed by its alias. typedef- :: (Has sch schemas schema, Has td schema ('Typedef ty))+ :: (Has sch db schema, Has td schema ('Typedef ty)) => QualifiedAlias sch td- -> TypeExpression schemas (null ty)+ -- ^ type alias+ -> TypeExpression db (null ty) typedef = UnsafeTypeExpression . renderSQL -- | The composite type corresponding to a `Table` definition can be expressed--- by its alias.+-- by its alias. It is subsumed by `typerow` typetable- :: (Has sch schemas schema, Has tab schema ('Table table))+ :: (Has sch db schema, Has tab schema ('Table table)) => QualifiedAlias sch tab- -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))+ -- ^ table alias+ -> TypeExpression db (null ('PGcomposite (TableToRow table))) typetable = UnsafeTypeExpression . renderSQL -- | The composite type corresponding to a `View` definition can be expressed--- by its alias.+-- by its alias. It is subsumed by `typerow`. typeview- :: (Has sch schemas schema, Has vw schema ('View view))+ :: (Has sch db schema, Has vw schema ('View view)) => QualifiedAlias sch vw- -> TypeExpression schemas (null ('PGcomposite view))+ -- ^ view alias+ -> TypeExpression db (null ('PGcomposite view)) typeview = UnsafeTypeExpression . renderSQL -- | logical Boolean (true/false)-bool :: TypeExpression schemas (null 'PGbool)+bool :: TypeExpression db (null 'PGbool) bool = UnsafeTypeExpression "bool" -- | signed two-byte integer-int2, smallint :: TypeExpression schemas (null 'PGint2)+int2, smallint :: TypeExpression db (null 'PGint2) int2 = UnsafeTypeExpression "int2" smallint = UnsafeTypeExpression "smallint" -- | signed four-byte integer-int4, int, integer :: TypeExpression schemas (null 'PGint4)+int4, int, integer :: TypeExpression db (null 'PGint4) int4 = UnsafeTypeExpression "int4" int = UnsafeTypeExpression "int" integer = UnsafeTypeExpression "integer" -- | signed eight-byte integer-int8, bigint :: TypeExpression schemas (null 'PGint8)+int8, bigint :: TypeExpression db (null 'PGint8) int8 = UnsafeTypeExpression "int8" bigint = UnsafeTypeExpression "bigint" -- | arbitrary precision numeric type-numeric :: TypeExpression schemas (null 'PGnumeric)+numeric :: TypeExpression db (null 'PGnumeric) numeric = UnsafeTypeExpression "numeric" -- | single precision floating-point number (4 bytes)-float4, real :: TypeExpression schemas (null 'PGfloat4)+float4, real :: TypeExpression db (null 'PGfloat4) float4 = UnsafeTypeExpression "float4" real = UnsafeTypeExpression "real" -- | double precision floating-point number (8 bytes)-float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)+float8, doublePrecision :: TypeExpression db (null 'PGfloat8) float8 = UnsafeTypeExpression "float8" doublePrecision = UnsafeTypeExpression "double precision" -- | currency amount money :: TypeExpression schema (null 'PGmoney) money = UnsafeTypeExpression "money" -- | variable-length character string-text :: TypeExpression schemas (null 'PGtext)+text :: TypeExpression db (null 'PGtext) text = UnsafeTypeExpression "text" -- | fixed-length character string char, character- :: forall n schemas null. (KnownNat n, 1 <= n)- => TypeExpression schemas (null ('PGchar n))+ :: forall n db null. (KnownNat n, 1 <= n)+ => TypeExpression db (null ('PGchar n)) char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")" character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")" -- | variable-length character string varchar, characterVarying- :: forall n schemas null. (KnownNat n, 1 <= n)- => TypeExpression schemas (null ('PGvarchar n))+ :: forall n db null. (KnownNat n, 1 <= n)+ => TypeExpression db (null ('PGvarchar n)) varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")" characterVarying = UnsafeTypeExpression $ "character varying(" <> renderNat @n <> ")" -- | binary data ("byte array")-bytea :: TypeExpression schemas (null 'PGbytea)+bytea :: TypeExpression db (null 'PGbytea) bytea = UnsafeTypeExpression "bytea" -- | date and time (no time zone)-timestamp :: TypeExpression schemas (null 'PGtimestamp)+timestamp :: TypeExpression db (null 'PGtimestamp) timestamp = UnsafeTypeExpression "timestamp" -- | date and time, including time zone-timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)+timestampWithTimeZone, timestamptz :: TypeExpression db (null 'PGtimestamptz) timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"+timestamptz = UnsafeTypeExpression "timestamptz" -- | calendar date (year, month, day)-date :: TypeExpression schemas (null 'PGdate)+date :: TypeExpression db (null 'PGdate) date = UnsafeTypeExpression "date" -- | time of day (no time zone)-time :: TypeExpression schemas (null 'PGtime)+time :: TypeExpression db (null 'PGtime) time = UnsafeTypeExpression "time" -- | time of day, including time zone-timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)+timeWithTimeZone, timetz :: TypeExpression db (null 'PGtimetz) timeWithTimeZone = UnsafeTypeExpression "time with time zone"+timetz = UnsafeTypeExpression "timetz" -- | time span-interval :: TypeExpression schemas (null 'PGinterval)+interval :: TypeExpression db (null 'PGinterval) interval = UnsafeTypeExpression "interval" -- | universally unique identifier-uuid :: TypeExpression schemas (null 'PGuuid)+uuid :: TypeExpression db (null 'PGuuid) uuid = UnsafeTypeExpression "uuid" -- | IPv4 or IPv6 host address-inet :: TypeExpression schemas (null 'PGinet)+inet :: TypeExpression db (null 'PGinet) inet = UnsafeTypeExpression "inet" -- | textual JSON data-json :: TypeExpression schemas (null 'PGjson)+json :: TypeExpression db (null 'PGjson) json = UnsafeTypeExpression "json" -- | binary JSON data, decomposed-jsonb :: TypeExpression schemas (null 'PGjsonb)+jsonb :: TypeExpression db (null 'PGjsonb) jsonb = UnsafeTypeExpression "jsonb" -- | variable length array vararray- :: TypeExpression schemas pg- -> TypeExpression schemas (null ('PGvararray pg))+ :: TypeExpression db pg+ -> TypeExpression db (null ('PGvararray pg)) vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]" -- | fixed length array -- -- >>> renderSQL (fixarray @'[2] json) -- "json[2]" fixarray- :: forall dims schemas null pg. SOP.All KnownNat dims- => TypeExpression schemas pg- -> TypeExpression schemas (null ('PGfixarray dims pg))+ :: forall dims db null pg. SOP.All KnownNat dims+ => TypeExpression db pg+ -> TypeExpression db (null ('PGfixarray dims pg)) fixarray ty = UnsafeTypeExpression $ renderSQL ty <> renderDims @dims where@@ -262,46 +329,207 @@ . ByteString.intercalate "][" . SOP.hcollapse $ SOP.hcmap (SOP.Proxy @KnownNat)- (K . fromString . show . natVal)+ (SOP.K . fromString . show . natVal) (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns) -- | text search query-tsvector :: TypeExpression schemas (null 'PGtsvector)+tsvector :: TypeExpression db (null 'PGtsvector) tsvector = UnsafeTypeExpression "tsvector" -- | text search document-tsquery :: TypeExpression schemas (null 'PGtsquery)+tsquery :: TypeExpression db (null 'PGtsquery) tsquery = UnsafeTypeExpression "tsquery"+-- | Object identifiers (OIDs) are used internally by PostgreSQL+-- as primary keys for various system tables.+oid :: TypeExpression db (null 'PGoid)+oid = UnsafeTypeExpression "oid"+-- | Range of integer+int4range :: TypeExpression db (null ('PGrange 'PGint4))+int4range = UnsafeTypeExpression "int4range"+-- | Range of bigint+int8range :: TypeExpression db (null ('PGrange 'PGint8))+int8range = UnsafeTypeExpression "int8range"+-- | Range of numeric+numrange :: TypeExpression db (null ('PGrange 'PGnumeric))+numrange = UnsafeTypeExpression "numrange"+-- | Range of timestamp without time zone+tsrange :: TypeExpression db (null ('PGrange 'PGtimestamp))+tsrange = UnsafeTypeExpression "tsrange"+-- | Range of timestamp with time zone+tstzrange :: TypeExpression db (null ('PGrange 'PGtimestamptz))+tstzrange = UnsafeTypeExpression "tstzrange"+-- | Range of date+daterange :: TypeExpression db (null ('PGrange 'PGdate))+daterange = UnsafeTypeExpression "daterange"+-- | Anonymous composite record+record :: TypeExpression db (null ('PGcomposite record))+record = UnsafeTypeExpression "record" -- | `pgtype` is a demoted version of a `PGType`-class PGTyped schemas (ty :: NullityType) where- pgtype :: TypeExpression schemas ty-instance PGTyped schemas (null 'PGbool) where pgtype = bool-instance PGTyped schemas (null 'PGint2) where pgtype = int2-instance PGTyped schemas (null 'PGint4) where pgtype = int4-instance PGTyped schemas (null 'PGint8) where pgtype = int8-instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric-instance PGTyped schemas (null 'PGfloat4) where pgtype = float4-instance PGTyped schemas (null 'PGfloat8) where pgtype = float8-instance PGTyped schemas (null 'PGmoney) where pgtype = money-instance PGTyped schemas (null 'PGtext) where pgtype = text+class PGTyped db (ty :: PGType) where pgtype :: TypeExpression db (null ty)+instance PGTyped db 'PGbool where pgtype = bool+instance PGTyped db 'PGint2 where pgtype = int2+instance PGTyped db 'PGint4 where pgtype = int4+instance PGTyped db 'PGint8 where pgtype = int8+instance PGTyped db 'PGnumeric where pgtype = numeric+instance PGTyped db 'PGfloat4 where pgtype = float4+instance PGTyped db 'PGfloat8 where pgtype = float8+instance PGTyped db 'PGmoney where pgtype = money+instance PGTyped db 'PGtext where pgtype = text instance (KnownNat n, 1 <= n)- => PGTyped schemas (null ('PGchar n)) where pgtype = char @n+ => PGTyped db ('PGchar n) where pgtype = char @n instance (KnownNat n, 1 <= n)- => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n-instance PGTyped schemas (null 'PGbytea) where pgtype = bytea-instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp-instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone-instance PGTyped schemas (null 'PGdate) where pgtype = date-instance PGTyped schemas (null 'PGtime) where pgtype = time-instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone-instance PGTyped schemas (null 'PGinterval) where pgtype = interval-instance PGTyped schemas (null 'PGuuid) where pgtype = uuid-instance PGTyped schemas (null 'PGjson) where pgtype = json-instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb-instance PGTyped schemas ty- => PGTyped schemas (null ('PGvararray ty)) where- pgtype = vararray (pgtype @schemas @ty)-instance (SOP.All KnownNat dims, PGTyped schemas ty)- => PGTyped schemas (null ('PGfixarray dims ty)) where- pgtype = fixarray @dims (pgtype @schemas @ty)-instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector-instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery+ => PGTyped db ('PGvarchar n) where pgtype = varchar @n+instance PGTyped db 'PGbytea where pgtype = bytea+instance PGTyped db 'PGtimestamp where pgtype = timestamp+instance PGTyped db 'PGtimestamptz where pgtype = timestampWithTimeZone+instance PGTyped db 'PGdate where pgtype = date+instance PGTyped db 'PGtime where pgtype = time+instance PGTyped db 'PGtimetz where pgtype = timeWithTimeZone+instance PGTyped db 'PGinterval where pgtype = interval+instance PGTyped db 'PGuuid where pgtype = uuid+instance PGTyped db 'PGinet where pgtype = inet+instance PGTyped db 'PGjson where pgtype = json+instance PGTyped db 'PGjsonb where pgtype = jsonb+instance PGTyped db pg => PGTyped db ('PGvararray (null pg)) where+ pgtype = vararray (pgtype @db @pg)+instance (SOP.All KnownNat dims, PGTyped db pg)+ => PGTyped db ('PGfixarray dims (null pg)) where+ pgtype = fixarray @dims (pgtype @db @pg)+instance PGTyped db 'PGtsvector where pgtype = tsvector+instance PGTyped db 'PGtsquery where pgtype = tsquery+instance PGTyped db 'PGoid where pgtype = oid+instance PGTyped db ('PGrange 'PGint4) where pgtype = int4range+instance PGTyped db ('PGrange 'PGint8) where pgtype = int8range+instance PGTyped db ('PGrange 'PGnumeric) where pgtype = numrange+instance PGTyped db ('PGrange 'PGtimestamp) where pgtype = tsrange+instance PGTyped db ('PGrange 'PGtimestamptz) where pgtype = tstzrange+instance PGTyped db ('PGrange 'PGdate) where pgtype = daterange+instance+ ( relss ~ DbRelations db+ , Has sch relss rels+ , Has rel rels row+ , FindQualified "no relation found with row:" relss row ~ '(sch,rel) + ) => PGTyped db ('PGcomposite row) where+ pgtype = typerow (QualifiedAlias @sch @rel)+instance+ ( enums ~ DbEnums db+ , FindQualified "no enum found with labels:" enums labels ~ '(sch,td)+ , Has sch db schema+ , Has td schema ('Typedef ('PGenum labels))+ ) => PGTyped db ('PGenum labels) where+ pgtype = typedef (QualifiedAlias @sch @td)++-- | Specify `TypeExpression` from a Haskell type.+--+-- >>> printSQL $ pgtypeFrom @String+-- text+--+-- >>> printSQL $ pgtypeFrom @Double+-- float8+pgtypeFrom+ :: forall hask db null. PGTyped db (PG hask)+ => TypeExpression db (null (PG hask))+pgtypeFrom = pgtype @db @(PG hask)++-- | Lift `PGTyped` to a field+class FieldTyped db ty where fieldtype :: Aliased (TypeExpression db) ty+instance (KnownSymbol alias, NullTyped db ty)+ => FieldTyped db (alias ::: ty) where+ fieldtype = nulltype `As` Alias++-- | `ColumnTypeExpression`s are used in+-- `Squeal.PostgreSQL.Definition.createTable` commands.+newtype ColumnTypeExpression (db :: SchemasType) (ty :: ColumnType)+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (ColumnTypeExpression db ty) where+ renderSQL = renderColumnTypeExpression++-- | used in `Squeal.PostgreSQL.Definition.createTable`+-- commands as a column constraint to note that+-- @NULL@ may be present in a column+nullable+ :: TypeExpression db (null ty)+ -- ^ type+ -> ColumnTypeExpression db ('NoDef :=> 'Null ty)+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"++-- | used in `Squeal.PostgreSQL.Definition.createTable`+-- commands as a column constraint to ensure+-- @NULL@ is not present in a column+notNullable+ :: TypeExpression db (null ty)+ -- ^ type+ -> ColumnTypeExpression db ('NoDef :=> 'NotNull ty)+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"++-- | used in `Squeal.PostgreSQL.Definition.createTable`+-- commands as a column constraint to give a default+default_+ :: Expression 'Ungrouped '[] '[] db '[] '[] ty+ -- ^ default value+ -> ColumnTypeExpression db ('NoDef :=> ty)+ -- ^ column type+ -> ColumnTypeExpression db ('Def :=> ty)+default_ x ty = UnsafeColumnTypeExpression $+ renderSQL ty <+> "DEFAULT" <+> renderExpression x++-- | not a true type, but merely a notational convenience for creating+-- unique identifier columns with type `PGint2`+serial2, smallserial+ :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint2)+serial2 = UnsafeColumnTypeExpression "serial2"+smallserial = UnsafeColumnTypeExpression "smallserial"+-- | not a true type, but merely a notational convenience for creating+-- unique identifier columns with type `PGint4`+serial4, serial+ :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint4)+serial4 = UnsafeColumnTypeExpression "serial4"+serial = UnsafeColumnTypeExpression "serial"+-- | not a true type, but merely a notational convenience for creating+-- unique identifier columns with type `PGint8`+serial8, bigserial+ :: ColumnTypeExpression db ('Def :=> 'NotNull 'PGint8)+serial8 = UnsafeColumnTypeExpression "serial8"+bigserial = UnsafeColumnTypeExpression "bigserial"++-- | Like @PGTyped@ but also accounts for null.+class NullTyped db (ty :: NullType) where+ nulltype :: TypeExpression db ty++instance PGTyped db ty => NullTyped db (null ty) where+ nulltype = pgtype @db @ty++-- | Specify null `TypeExpression` from a Haskell type.+--+-- >>> printSQL $ nulltypeFrom @(Maybe String)+-- text+--+-- >>> printSQL $ nulltypeFrom @Double+-- float8+nulltypeFrom+ :: forall hask db. NullTyped db (NullPG hask)+ => TypeExpression db (NullPG hask)+nulltypeFrom = nulltype @db @(NullPG hask)++-- | Like @PGTyped@ but also accounts for null.+class ColumnTyped db (column :: ColumnType) where+ columntype :: ColumnTypeExpression db column+instance NullTyped db ('Null ty)+ => ColumnTyped db ('NoDef :=> 'Null ty) where+ columntype = nullable (nulltype @db @('Null ty))+instance NullTyped db ('NotNull ty)+ => ColumnTyped db ('NoDef :=> 'NotNull ty) where+ columntype = notNullable (nulltype @db @('NotNull ty))++-- | Specify `ColumnTypeExpression` from a Haskell type.+--+-- >>> printSQL $ columntypeFrom @(Maybe String)+-- text NULL+--+-- >>> printSQL $ columntypeFrom @Double+-- float8 NOT NULL+columntypeFrom+ :: forall hask db. (ColumnTyped db ('NoDef :=> NullPG hask))+ => ColumnTypeExpression db ('NoDef :=> NullPG hask)+columntypeFrom = columntype @db @('NoDef :=> NullPG hask)
src/Squeal/PostgreSQL/Expression/Window.hs view
@@ -1,30 +1,47 @@ {-| Module: Squeal.PostgreSQL.Expression.Window-Description: Window functions+Description: window functions, arguments and definitions Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Window functions and definitions+window functions, arguments and definitions -} {-# LANGUAGE DataKinds , DeriveGeneric+ , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving+ , KindSignatures , LambdaCase , MultiParamTypeClasses , OverloadedStrings+ , PatternSynonyms , RankNTypes- , KindSignatures+ , ScopedTypeVariables+ , TypeApplications+ , TypeOperators+ , UndecidableInstances #-} module Squeal.PostgreSQL.Expression.Window- ( -- * functions- partitionBy+ ( -- * Window Definition+ WindowDefinition (..)+ , partitionBy+ -- * Window Function+ -- ** Types+ , WindowFunction (..)+ , WindowArg (..)+ , pattern Window+ , pattern Windows+ , WinFun0+ , type (-#->)+ , type (--#->)+ -- ** Functions , rank , rowNumber , denseRank@@ -38,91 +55,79 @@ , nthValue , unsafeWindowFunction1 , unsafeWindowFunctionN- -- * types- , WindowFunction (..)- , WindowDefinition (..)- , WinFun0- , WinFun1- , WinFunN ) where import Control.DeepSeq-import Data.ByteString+import Data.ByteString (ByteString) import qualified GHC.Generics as GHC import qualified Generics.SOP as SOP -import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Aggregate+import Squeal.PostgreSQL.Expression.Logic import Squeal.PostgreSQL.Expression.Sort-import Squeal.PostgreSQL.List+import Squeal.PostgreSQL.Type.List import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -instance Aggregate- (Expression outer commons grp schemas params from)- (NP (Expression outer commons grp schemas params from))- (WindowFunction outer commons grp schemas params from) where- countStar = UnsafeWindowFunction "count(*)"- count = unsafeWindowFunction1 "count"- sum_ = unsafeWindowFunction1 "sum"- arrayAgg = unsafeWindowFunction1 "array_agg"- jsonAgg = unsafeWindowFunction1 "json_agg"- jsonbAgg = unsafeWindowFunction1 "jsonb_agg"- bitAnd = unsafeWindowFunction1 "bit_and"- bitOr = unsafeWindowFunction1 "bit_or"- boolAnd = unsafeWindowFunction1 "bool_and"- boolOr = unsafeWindowFunction1 "bool_or"- every = unsafeWindowFunction1 "every"- max_ = unsafeWindowFunction1 "max"- min_ = unsafeWindowFunction1 "min"- avg = unsafeWindowFunction1 "avg"- corr = unsafeWindowFunctionN "corr"- covarPop = unsafeWindowFunctionN "covar_pop"- covarSamp = unsafeWindowFunctionN "covar_samp"- regrAvgX = unsafeWindowFunctionN "regr_avgx"- regrAvgY = unsafeWindowFunctionN "regr_avgy"- regrCount = unsafeWindowFunctionN "regr_count"- regrIntercept = unsafeWindowFunctionN "regr_intercept"- regrR2 = unsafeWindowFunctionN "regr_r2"- regrSlope = unsafeWindowFunctionN "regr_slope"- regrSxx = unsafeWindowFunctionN "regr_sxx"- regrSxy = unsafeWindowFunctionN "regr_sxy"- regrSyy = unsafeWindowFunctionN "regr_syy"- stddev = unsafeWindowFunction1 "stddev"- stddevPop = unsafeWindowFunction1 "stddev_pop"- stddevSamp = unsafeWindowFunction1 "stddev_samp"- variance = unsafeWindowFunction1 "variance"- varPop = unsafeWindowFunction1 "var_pop"- varSamp = unsafeWindowFunction1 "var_samp"+instance Aggregate (WindowArg grp) (WindowFunction grp) where+ countStar = UnsafeWindowFunction "count(*)"+ count = unsafeWindowFunction1 "count"+ sum_ = unsafeWindowFunction1 "sum"+ arrayAgg = unsafeWindowFunction1 "array_agg"+ jsonAgg = unsafeWindowFunction1 "json_agg"+ jsonbAgg = unsafeWindowFunction1 "jsonb_agg"+ bitAnd = unsafeWindowFunction1 "bit_and"+ bitOr = unsafeWindowFunction1 "bit_or"+ boolAnd = unsafeWindowFunction1 "bool_and"+ boolOr = unsafeWindowFunction1 "bool_or"+ every = unsafeWindowFunction1 "every"+ max_ = unsafeWindowFunction1 "max"+ min_ = unsafeWindowFunction1 "min"+ avg = unsafeWindowFunction1 "avg"+ corr = unsafeWindowFunctionN "corr"+ covarPop = unsafeWindowFunctionN "covar_pop"+ covarSamp = unsafeWindowFunctionN "covar_samp"+ regrAvgX = unsafeWindowFunctionN "regr_avgx"+ regrAvgY = unsafeWindowFunctionN "regr_avgy"+ regrCount = unsafeWindowFunctionN "regr_count"+ regrIntercept = unsafeWindowFunctionN "regr_intercept"+ regrR2 = unsafeWindowFunctionN "regr_r2"+ regrSlope = unsafeWindowFunctionN "regr_slope"+ regrSxx = unsafeWindowFunctionN "regr_sxx"+ regrSxy = unsafeWindowFunctionN "regr_sxy"+ regrSyy = unsafeWindowFunctionN "regr_syy"+ stddev = unsafeWindowFunction1 "stddev"+ stddevPop = unsafeWindowFunction1 "stddev_pop"+ stddevSamp = unsafeWindowFunction1 "stddev_samp"+ variance = unsafeWindowFunction1 "variance"+ varPop = unsafeWindowFunction1 "var_pop"+ varSamp = unsafeWindowFunction1 "var_samp" -- | A `WindowDefinition` is a set of table rows that are somehow related -- to the current row-data WindowDefinition outer commons grp schemas params from where+data WindowDefinition grp lat with db params from where WindowDefinition :: SOP.SListI bys- => NP (Expression outer commons grp schemas params from) bys+ => NP (Expression grp lat with db params from) bys -- ^ `partitionBy` clause- -> [SortExpression outer commons grp schemas params from]+ -> [SortExpression grp lat with db params from] -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause- -> WindowDefinition outer commons grp schemas params from+ -> WindowDefinition grp lat with db params from -instance OrderBy WindowDefinition where+instance OrderBy (WindowDefinition grp) grp where orderBy sortsR (WindowDefinition parts sortsL) = WindowDefinition parts (sortsL ++ sortsR) -instance RenderSQL (WindowDefinition outer commons schemas from grp params) where+instance RenderSQL (WindowDefinition grp lat with db params from) where renderSQL (WindowDefinition part ord) =- renderPartitionByClause part <> renderOrderByClause ord+ renderPartitionByClause part <> renderSQL ord where renderPartitionByClause = \case Nil -> "" parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts- renderOrderByClause = \case- [] -> ""- srts -> " ORDER" <+> "BY"- <+> commaSeparated (renderSQL <$> srts) {- | The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,@@ -132,8 +137,8 @@ -} partitionBy :: SOP.SListI bys- => NP (Expression outer commons grp schemas params from) bys -- ^ partitions- -> WindowDefinition outer commons grp schemas params from+ => NP (Expression grp lat with db params from) bys -- ^ partitions+ -> WindowDefinition grp lat with db params from partitionBy bys = WindowDefinition bys [] {- |@@ -147,57 +152,116 @@ just the current row of the query result. -} newtype WindowFunction- (outer :: FromType)- (commons :: FromType) (grp :: Grouping)- (schemas :: SchemasType)- (params :: [NullityType])+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType]) (from :: FromType)- (ty :: NullityType)+ (ty :: NullType) = UnsafeWindowFunction { renderWindowFunction :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData) -instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where+{- |+`WindowArg`s are used for the input of `WindowFunction`s.+-}+data WindowArg+ (grp :: Grouping)+ (args :: [NullType])+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (from :: FromType)+ = WindowArg+ { windowArgs :: NP (Expression grp lat with db params from) args+ -- ^ `Window` or `Windows`+ , windowFilter :: [Condition grp lat with db params from]+ -- ^ `filterWhere`+ } deriving stock (GHC.Generic)++instance (HasUnique tab (Join from lat) row, Has col row ty)+ => IsLabel col (WindowArg 'Ungrouped '[ty] lat with db params from) where+ fromLabel = Window (fromLabel @col)+instance (Has tab (Join from lat) row, Has col row ty)+ => IsQualified tab col (WindowArg 'Ungrouped '[ty] lat with db params from) where+ tab ! col = Window (tab ! col)+instance (HasUnique tab (Join from lat) row, Has col row ty, GroupedBy tab col bys)+ => IsLabel col (WindowArg ('Grouped bys) '[ty] lat with db params from) where+ fromLabel = Window (fromLabel @col)+instance (Has tab (Join from lat) row, Has col row ty, GroupedBy tab col bys)+ => IsQualified tab col (WindowArg ('Grouped bys) '[ty] lat with db params from) where+ tab ! col = Window (tab ! col)++instance SOP.SListI args+ => RenderSQL (WindowArg grp args lat with db params from) where+ renderSQL (WindowArg args filters) =+ parenthesized (renderCommaSeparated renderSQL args)+ & renderFilters filters+ where+ renderFilter wh = "FILTER" <+> parenthesized ("WHERE" <+> wh)+ renderFilters = \case+ [] -> id+ wh:whs -> (<+> renderFilter (renderSQL (foldr (.&&) wh whs)))++instance FilterWhere (WindowArg grp) grp where+ filterWhere wh (WindowArg args filters) = WindowArg args (wh : filters)++-- | `Window` invokes a `WindowFunction` on a single argument.+pattern Window+ :: Expression grp lat with db params from arg+ -- ^ argument+ -> WindowArg grp '[arg] lat with db params from+pattern Window x = Windows (x :* Nil)++-- | `Windows` invokes a `WindowFunction` on multiple argument.+pattern Windows+ :: NP (Expression grp lat with db params from) args+ -- ^ arguments+ -> WindowArg grp args lat with db params from+pattern Windows xs = WindowArg xs []++instance RenderSQL (WindowFunction grp lat with db params from ty) where renderSQL = renderWindowFunction {- | A @RankNType@ for window functions with no arguments. -} type WinFun0 x- = forall outer commons grp schemas params from- . WindowFunction outer commons grp schemas params from x+ = forall grp lat with db params from+ . WindowFunction grp lat with db params from x -- ^ cannot reference aliases {- | A @RankNType@ for window functions with 1 argument. -}-type WinFun1 x y- = forall outer commons grp schemas params from- . Expression outer commons grp schemas params from x+type (-#->) x y+ = forall grp lat with db params from+ . WindowArg grp '[x] lat with db params from -- ^ input- -> WindowFunction outer commons grp schemas params from y+ -> WindowFunction grp lat with db params from y -- ^ output {- | A @RankNType@ for window functions with a fixed-length list of heterogeneous arguments. Use the `*:` operator to end your argument lists. -}-type WinFunN xs y- = forall outer commons grp schemas params from- . NP (Expression outer commons grp schemas params from) xs+type (--#->) xs y+ = forall grp lat with db params from+ . WindowArg grp xs lat with db params from -- ^ inputs- -> WindowFunction outer commons grp schemas params from y+ -> WindowFunction grp lat with db params from y -- ^ output -- | escape hatch for defining window functions-unsafeWindowFunction1 :: ByteString -> WinFun1 x y+unsafeWindowFunction1 :: ByteString -> x -#-> y unsafeWindowFunction1 fun x- = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)+ = UnsafeWindowFunction $ fun <> renderSQL x -- | escape hatch for defining multi-argument window functions-unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y-unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>- parenthesized (renderCommaSeparated renderSQL xs)+unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> xs --#-> y+unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <> renderSQL xs {- | rank of the current row with gaps; same as `rowNumber` of its first peer @@ -243,10 +307,10 @@ {- | integer ranging from 1 to the argument value, dividing the partition as equally as possible ->>> printSQL $ ntile 5-ntile(5)+>>> printSQL $ ntile (Window 5)+ntile((5 :: int4)) -}-ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)+ntile :: 'NotNull 'PGint4 -#-> 'NotNull 'PGint4 ntile = unsafeWindowFunction1 "ntile" {- | returns value evaluated at the row that is offset rows before the current@@ -254,7 +318,7 @@ (which must be of the same type as value). Both offset and default are evaluated with respect to the current row. -}-lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty+lag :: '[ty, 'NotNull 'PGint4, ty] --#-> ty lag = unsafeWindowFunctionN "lag" {- | returns value evaluated at the row that is offset rows after the current@@ -262,23 +326,23 @@ (which must be of the same type as value). Both offset and default are evaluated with respect to the current row. -}-lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty+lead :: '[ty, 'NotNull 'PGint4, ty] --#-> ty lead = unsafeWindowFunctionN "lead" {- | returns value evaluated at the row that is the first row of the window frame -}-firstValue :: WinFun1 ty ty+firstValue :: ty -#-> ty firstValue = unsafeWindowFunction1 "first_value" {- | returns value evaluated at the row that is the last row of the window frame -}-lastValue :: WinFun1 ty ty+lastValue :: ty -#-> ty lastValue = unsafeWindowFunction1 "last_value" {- | returns value evaluated at the row that is the nth row of the window frame (counting from 1); null if no such row -}-nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)+nthValue :: '[null ty, 'NotNull 'PGint4] --#-> 'Null ty nthValue = unsafeWindowFunctionN "nth_value"
− src/Squeal/PostgreSQL/List.hs
@@ -1,141 +0,0 @@-{-|-Module: Squeal.PostgreSQL.List-Description: List related types and functions-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--Haskell singly-linked lists are very powerful. This module-provides functionality for type-level lists, heterogeneous-lists and type aligned lists.--}--{-# LANGUAGE- DataKinds- , FlexibleContexts- , GADTs- , LambdaCase- , MultiParamTypeClasses- , OverloadedStrings- , PolyKinds- , QuantifiedConstraints- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , TypeOperators- , UndecidableInstances-#-}--module Squeal.PostgreSQL.List- ( SOP.NP (..)- , (*:)- , Join- , disjoin- , Additional (..)- , AlignedList (..)- , single- , extractList- , mapAligned- , Elem- , In- , Length- ) where--import Control.Category-import Data.Function ((&))-import Data.Kind-import Data.Type.Bool-import GHC.TypeLits--import Generics.SOP as SOP--import Squeal.PostgreSQL.Render---- | `Join` is simply promoted `++` and is used in @JOIN@s in--- `Squeal.PostgreSQL.Query.FromClause`s.-type family Join xs ys where- Join '[] ys = ys- Join (x ': xs) ys = x ': Join xs ys---- | `disjoin` is a utility function for splitting an `NP` list into pieces.-disjoin- :: forall xs ys expr. SListI xs- => NP expr (Join xs ys)- -> (NP expr xs, NP expr ys)-disjoin = case sList @xs of- SNil -> \ys -> (Nil, ys)- SCons -> \(x :* xsys) ->- case disjoin xsys of (xs,ys) -> (x :* xs, ys)---- | The `Additional` class is for appending--- type-level list parameterized constructors such as `NP`,--- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.-class Additional expr where- also :: expr ys -> expr xs -> expr (Join xs ys)-instance Additional (NP expr) where- also ys = \case- Nil -> ys- x :* xs -> x :* (xs & also ys)---- | An `AlignedList` is a type-aligned list or free category.-data AlignedList p x0 x1 where- Done :: AlignedList p x x- (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2-infixr 7 :>>-instance Category (AlignedList p) where- id = Done- (.) list = \case- Done -> list- step :>> steps -> step :>> (steps >>> list)-instance (forall t0 t1. RenderSQL (p t0 t1))- => RenderSQL (AlignedList p x0 x1) where- renderSQL = \case- Done -> ""- step :>> Done -> renderSQL step- step :>> steps -> renderSQL step <> ", " <> renderSQL steps---- | `extractList` turns an `AlignedList` into a standard list.-extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]-extractList f = \case- Done -> []- step :>> steps -> (f step):extractList f steps---- | `mapAligned` applies a function to each element of an `AlignedList`.-mapAligned- :: (forall z0 z1. p z0 z1 -> q z0 z1)- -> AlignedList p x0 x1- -> AlignedList q x0 x1-mapAligned f = \case- Done -> Done- x :>> xs -> f x :>> mapAligned f xs---- | A `single` step.-single :: p x0 x1 -> AlignedList p x0 x1-single step = step :>> Done---- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.-(*:) :: f x -> f y -> NP f '[x,y]-x *: y = x :* y :* Nil-infixl 9 *:---- | @Elem@ is a promoted `Data.List.elem`.-type family Elem x xs where- Elem x '[] = 'False- Elem x (x ': xs) = 'True- Elem x (_ ': xs) = Elem x xs---- | @In x xs@ is a constraint that proves that @x@ is in @xs@.-type family In x xs :: Constraint where- In x xs = If (Elem x xs) (() :: Constraint)- (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))--{- | Calculate the `Length` of a type level list-->>> :kind! Length '[Char,String,Bool,Double]-Length '[Char,String,Bool,Double] :: Nat-= 4--}-type family Length (xs :: [k]) :: Nat where- Length (x : xs) = 1 + Length xs- Length '[] = 0
src/Squeal/PostgreSQL/Manipulation.hs view
@@ -1,15 +1,16 @@ {-| Module: Squeal.PostgreSQL.Manipulation-Description: Squeal data manipulation language-Copyright: (c) Eitan Chatav, 2017+Description: data manipulation language+Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Squeal data manipulation language.+data manipulation language -} {-# LANGUAGE DeriveGeneric+ , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs@@ -23,52 +24,40 @@ , ScopedTypeVariables , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , UndecidableInstances #-} module Squeal.PostgreSQL.Manipulation ( -- * Manipulation- Manipulation_- , Manipulation (..)+ Manipulation (..)+ , Manipulation_ , queryStatement- -- * Insert- , insertInto- , insertInto_- -- * Update- , update- , update_- -- * Delete- , deleteFrom- , deleteFrom_- -- * Clauses- , Optional (..)- , QueryClause (..)- , pattern Values_ , ReturningClause (..) , pattern Returning_- , ConflictClause (..)- , ConflictTarget (..)- , ConflictAction (..) , UsingClause (..) ) where import Control.DeepSeq import Data.ByteString hiding (foldr) import Data.Kind (Type)+import Data.Quiver.Functor import qualified Generics.SOP as SOP import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Alias+import Squeal.PostgreSQL.Type.Alias import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Expression.Logic-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.PG+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render import Squeal.PostgreSQL.Query-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Query.From+import Squeal.PostgreSQL.Query.Select+import Squeal.PostgreSQL.Query.With+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -77,88 +66,79 @@ {- | A `Manipulation` is a statement which may modify data in the database,-but does not alter its schemas. Examples are inserts, updates and deletes.-A `Query` is also considered a `Manipulation` even though it does not modify data.+but does not alter its schemas. Examples are+`Squeal.PostgreSQL.Manipulation.Insert.insertInto`s,+`Squeal.PostgreSQL.Manipulation.Update.update`s and+`Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`s.+A `queryStatement` is also considered a `Manipulation` even though it does not modify data. The general `Manipulation` type is parameterized by -* @commons :: FromType@ - scope for all `common` table expressions,-* @schemas :: SchemasType@ - scope for all `table`s and `view`s,-* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,-* @row :: RowType@ - return type of the `Query`.--}-newtype Manipulation- (commons :: FromType)- (schemas :: SchemasType)- (params :: [NullityType])- (columns :: RowType)- = UnsafeManipulation { renderManipulation :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (Manipulation commons schemas params columns) where- renderSQL = renderManipulation-instance With Manipulation where- with Done manip = manip- with ctes manip = UnsafeManipulation $- "WITH" <+> renderSQL ctes <+> renderSQL manip--{- |-The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,-against which the query is type-checked, an input @parameters@ Haskell `Type`,-and an ouput row Haskell `Type`.+* @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions,+* @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s,+* @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,+* @row :: RowType@ - return type of the `Manipulation`. -A top-level `Manipulation_` can be run-using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@-using `Squeal.PostgreSQL.PQ.manipulate`.+Let's see some examples of `Manipulation`s. -Generally, @parameters@ will be a Haskell tuple or record whose entries-may be referenced using positional-`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a-Haskell record, whose entries will be targeted using overloaded labels.+simple insert: ->>> :set -XDeriveAnyClass -XDerivingStrategies+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{-data Row a b = Row { col1 :: a, col2 :: b }- deriving stock (GHC.Generic)- deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+let+ manp :: Manipulation with (Public Schema) '[] '[]+ manp =+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))+in printSQL manp :}+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT) -simple insert:+out-of-line parameterized insert: ->>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- manipulation :: Manipulation_ (Public Schema) () ()- manipulation =- insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[]+ manp =+ insertInto_ #tab $ Values_+ (Default `as` #col1 :* Set (param @1) `as` #col2)+in printSQL manp :}-INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, ($1 :: int4)) -parameterized insert:+in-line parameterized insert: ->>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4] >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{+data Row = Row { col1 :: Optional SOP.I ('Def :=> Int32), col2 :: Int32 }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :{ let- manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()- manipulation =- insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))-in printSQL manipulation+ manp :: Row -> Row -> Manipulation with (Public Schema) '[] '[]+ manp row1 row2 = insertInto_ #tab $ inlineValues row1 [row2]+ row1 = Row {col1 = Default, col2 = 2 :: Int32}+ row2 = Row {col1 = NotDefault (3 :: Int32), col2 = 4 :: Int32}+in printSQL (manp row1 row2) :}-INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES (DEFAULT, (2 :: int4)), ((3 :: int4), (4 :: int4)) returning insert: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () (Only Int32)- manipulation =+ manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4]+ manp = insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))- OnConflictDoRaise (Returning (#col1 `as` #fromOnly))-in printSQL manipulation+ OnConflictDoRaise (Returning #col1)+in printSQL manp :}-INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), (3 :: int4)) RETURNING "col1" AS "col1" upsert: @@ -167,46 +147,46 @@ >>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)] >>> :{ let- manipulation :: Manipulation_ (Public CustomersSchema) () ()- manipulation =+ manp :: Manipulation with (Public CustomersSchema) '[] '[]+ manp = insertInto #customers (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email)) (OnConflict (OnConstraint #uq) (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) [])) (Returning_ Nil)-in printSQL manipulation+in printSQL manp :}-INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email"))+INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email")) query insert: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () ()- manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = insertInto_ #tab (Subquery (select Star (from (table #tab))))+in printSQL manp :}-INSERT INTO "tab" SELECT * FROM "tab" AS "tab"+INSERT INTO "tab" AS "tab" SELECT * FROM "tab" AS "tab" update: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () ()- manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)+in printSQL manp :}-UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")+UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2") delete: >>> :{ let- manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)- manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)-in printSQL manipulation+ manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ manp = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)+in printSQL manp :}-DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *+DELETE FROM "tab" AS "tab" WHERE ("col1" = "col2") RETURNING * delete and using clause: @@ -219,15 +199,15 @@ >>> :{ let- manipulation :: Manipulation_ (Public Schema3) () ()- manipulation =+ manp :: Manipulation with (Public Schema3) '[] '[]+ manp = deleteFrom #tab (Using (table #other_tab & also (table #third_tab))) ( (#tab ! #col2 .== #other_tab ! #col2) .&& (#tab ! #col2 .== #third_tab ! #col2) ) (Returning_ Nil)-in printSQL manipulation+in printSQL manp :}-DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))+DELETE FROM "tab" AS "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2")) with manipulation: @@ -235,151 +215,106 @@ >>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)] >>> :{ let- manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()- manipulation = with+ manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]+ manp = with (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del) (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))-in printSQL manipulation+in printSQL manp :}-WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"+WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del" -}-type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where- Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)---- | Convert a `Query` into a `Manipulation`.-queryStatement- :: Query '[] commons schemas params columns- -> Manipulation commons schemas params columns-queryStatement q = UnsafeManipulation $ renderSQL q--{------------------------------------------INSERT statements------------------------------------------}+newtype Manipulation+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (columns :: RowType)+ = UnsafeManipulation { renderManipulation :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (Manipulation with db params columns) where+ renderSQL = renderManipulation+instance With Manipulation where+ with Done manip = manip+ with ctes manip = UnsafeManipulation $+ "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL manip {- |-When a table is created, it contains no data. The first thing to do-before a database can be of much use is to insert data. Data is-conceptually inserted one row at a time. Of course you can also insert-more than one row, but there is no way to insert less than one row.-Even if you know only some column values, a complete row must be created.--}-insertInto- :: ( Has sch schemas schema- , Has tab schema ('Table table)- , columns ~ TableToColumns table- , row0 ~ TableToRow table- , SOP.SListI columns- , SOP.SListI row1 )- => QualifiedAlias sch tab- -> QueryClause commons schemas params columns- -> ConflictClause tab commons schemas params table- -> ReturningClause commons schemas params '[tab ::: row0] row1- -> Manipulation commons schemas params row1-insertInto tab qry conflict ret = UnsafeManipulation $- "INSERT" <+> "INTO" <+> renderSQL tab- <+> renderSQL qry- <> renderSQL conflict- <> renderSQL ret+The `Manipulation_` type is parameterized by a @db@ `SchemasType`,+against which it is type-checked, an input @params@ Haskell `Type`,+and an ouput row Haskell `Type`. --- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.-insertInto_- :: ( Has sch schemas schema- , Has tab schema ('Table table)- , columns ~ TableToColumns table- , row ~ TableToRow table- , SOP.SListI columns )- => QualifiedAlias sch tab- -> QueryClause commons schemas params columns- -> Manipulation commons schemas params '[]-insertInto_ tab qry =- insertInto tab qry OnConflictDoRaise (Returning_ Nil)+Generally, @params@ will be a Haskell tuple or record whose entries+may be referenced using positional+`Squeal.PostgreSQL.Expression.Parameter.param`s and @row@ will be a+Haskell record, whose entries will be targeted using overloaded labels. --- | A `QueryClause` describes what to `insertInto` a table.-data QueryClause commons schemas params columns where- -- | `Values` describes `NP` lists of `Aliased` `Optional` `Expression`s- -- whose `ColumnsType` must match the tables'.- Values- :: SOP.SListI columns- => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns- -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]- -> QueryClause commons schemas params columns- -- | `Select` describes a subquery that permits use of `Optional` `Expression`s.- Select- :: SOP.SListI columns- => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns- -> TableExpression '[] commons grp schemas params from- -> QueryClause commons schemas params columns- -- | `Subquery` describes a subquery whose `RowType` must match the tables'.- Subquery- :: ColumnsToRow columns ~ row- => Query '[] commons schemas params row- -> QueryClause commons schemas params columns+A `Manipulation_` can be run+using `Squeal.PostgreSQL.Session.manipulateParams`, or if @params = ()@+using `Squeal.PostgreSQL.Session.manipulate`. -instance RenderSQL (QueryClause commons schemas params columns) where- renderSQL = \case- Values row0 rows ->- parenthesized (renderCommaSeparated renderSQLPart row0)- <+> "VALUES"- <+> commaSeparated- ( parenthesized- . renderCommaSeparated renderValuePart <$> row0 : rows )- Select row0 tab ->- parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)- <+> "SELECT"- <+> renderCommaSeparatedMaybe renderValuePartMaybe row0- <+> renderSQL tab- Subquery qry -> renderQuery qry- where- renderSQLPartMaybe, renderValuePartMaybe- :: Aliased (Optional (Expression '[] commons grp schemas params from)) column- -> Maybe ByteString- renderSQLPartMaybe = \case- Default `As` _ -> Nothing- Set _ `As` name -> Just $ renderSQL name- renderValuePartMaybe = \case- Default `As` _ -> Nothing- Set value `As` _ -> Just $ renderExpression value- renderSQLPart, renderValuePart- :: Aliased (Optional (Expression '[] commons grp schemas params from)) column- -> ByteString- renderSQLPart (_ `As` name) = renderSQL name- renderValuePart (value `As` _) = renderSQL value+`Manipulation_` is a type family which resolves into a `Manipulation`,+so don't be fooled by the input params and output row Haskell `Type`s,+which are converted into appropriate+Postgres @[@`NullType`@]@ params and `RowType` rows.+Use `Squeal.PostgreSQL.Session.Statement.manipulation` to+fix actual Haskell input params and output rows. --- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s--- whose `ColumnsType` must match the tables'.-pattern Values_- :: SOP.SListI columns- => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns- -> QueryClause commons schemas params columns-pattern Values_ vals = Values vals []+>>> :set -XDeriveAnyClass -XDerivingStrategies+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+data Row = Row { col1 :: Maybe Int64, col2 :: String }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:} --- | `Optional` is either `Default` or a value, parameterized by an appropriate--- `ColumnConstraint`.-data Optional expr ty where- -- | Use the `Default` value for a column.- Default :: Optional expr ('Def :=> ty)- -- | `Set` a value for a column.- Set :: expr ty -> Optional expr (def :=> ty)+>>> :{+let+ manp :: Manipulation_ (Public Schema) (Int64, Int64) Row+ manp = deleteFrom #tab NoUsing (#col1 .== param @1 + param @2) (Returning Star)+ stmt :: Statement (Public Schema) (Int64, Int64) Row+ stmt = manipulation manp+:} -instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where- renderSQL = \case- Default -> "DEFAULT"- Set expr -> renderSQL expr+>>> :type manp+manp+ :: Manipulation+ '[]+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ '[ 'NotNull 'PGint8, 'NotNull 'PGint8]+ '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext]+>>> :type stmt+stmt+ :: Statement+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ (Int64, Int64)+ Row+-}+type family Manipulation_ (db :: SchemasType) (params :: Type) (row :: Type) where+ Manipulation_ db params row = Manipulation '[] db (TuplePG params) (RowPG row) --- | A `ReturningClause` computes and return value(s) based+-- | Convert a `Query` into a `Manipulation`.+queryStatement+ :: Query '[] with db params columns+ -- ^ `Query` to embed as a `Manipulation`+ -> Manipulation with db params columns+queryStatement q = UnsafeManipulation $ renderSQL q++-- | A `ReturningClause` computes and returns value(s) based -- on each row actually inserted, updated or deleted. This is primarily -- useful for obtaining values that were supplied by defaults, such as a -- serial sequence number. However, any expression using the table's columns -- 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 `OnConflict` `DoUpdate` condition was not satisfied,+-- but not updated because an `Squeal.PostgreSQL.Manipulation.Insert.OnConflict`+-- `Squeal.PostgreSQL.Manipulation.Insert.DoUpdate` condition was not satisfied, -- the row will not be returned. `Returning` `Star` will return all columns--- in the row. Use @Returning Nil@ in the common case where no return+-- in the row. Use `Returning_` `Nil` in the common case where no return -- values are desired.-newtype ReturningClause commons schemas params from row =- Returning (Selection '[] commons 'Ungrouped schemas params from row)+newtype ReturningClause with db params from row =+ Returning (Selection 'Ungrouped '[] with db params from row) -instance RenderSQL (ReturningClause commons schemas params from row) where+instance RenderSQL (ReturningClause with db params from row) where renderSQL = \case Returning (List Nil) -> "" Returning selection -> " RETURNING" <+> renderSQL selection@@ -387,183 +322,23 @@ -- | `Returning` a `List` pattern Returning_ :: SOP.SListI row- => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row- -> ReturningClause commons schemas params from row+ => NP (Aliased (Expression 'Ungrouped '[] with db params from)) row+ -- ^ row of values+ -> ReturningClause with db params from row pattern Returning_ list = Returning (List list) --- | A `ConflictClause` specifies an action to perform upon a constraint--- violation. `OnConflictDoRaise` will raise an error.--- `OnConflict` `DoNothing` simply avoids inserting a row.--- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row--- proposed for insertion.-data ConflictClause tab commons schemas params table where- OnConflictDoRaise :: ConflictClause tab commons schemas params table- OnConflict- :: ConflictTarget constraints- -> ConflictAction tab commons schemas params columns- -> ConflictClause tab commons schemas params (constraints :=> columns)---- | Render a `ConflictClause`.-instance SOP.SListI (TableToColumns table)- => RenderSQL (ConflictClause tab commons schemas params table) where- renderSQL = \case- OnConflictDoRaise -> ""- OnConflict target action -> " ON CONFLICT"- <+> renderSQL target <+> renderSQL action--{- |-`ConflictAction` specifies an alternative `OnConflict` action.-It can be either `DoNothing`, or a `DoUpdate` clause specifying-the exact details of the `update` action to be performed in case of a conflict.-The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the-existing row using the table's name (or an alias), and to rows proposed-for insertion using the special @#excluded@ table.--}-data ConflictAction tab commons schemas params columns where- -- | `OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.- DoNothing :: ConflictAction tab commons schemas params columns- -- | `OnConflict` `DoUpdate` updates the existing row that conflicts- -- with the row proposed for insertion as its alternative action.- DoUpdate- :: ( row ~ ColumnsToRow columns- , SOP.SListI columns- , columns ~ (col0 ': cols)- , SOP.All (HasIn columns) subcolumns- , AllUnique subcolumns )- => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns- -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]- -- ^ WHERE `Condition`s- -> ConflictAction tab commons schemas params columns--instance RenderSQL (ConflictAction tab commons schemas params columns) where- renderSQL = \case- DoNothing -> "DO NOTHING"- DoUpdate updates whs'- -> "DO UPDATE SET"- <+> renderCommaSeparated renderUpdate updates- <> case whs' of- [] -> ""- wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)--renderUpdate- :: (forall x. RenderSQL (expr x))- => Aliased (Optional expr) ty- -> ByteString-renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr---- | A `ConflictTarget` specifies the constraint violation that triggers a--- `ConflictAction`.-data ConflictTarget constraints where- OnConstraint- :: Has con constraints constraint- => Alias con- -> ConflictTarget constraints---- | Render a `ConflictTarget`-instance RenderSQL (ConflictTarget constraints) where- renderSQL (OnConstraint con) =- "ON" <+> "CONSTRAINT" <+> renderSQL con--{------------------------------------------UPDATE statements------------------------------------------}---- | An `update` command changes the values of the specified columns--- in all rows that satisfy the condition.-update- :: ( SOP.SListI columns- , SOP.SListI row1- , db ~ (commons :=> schemas)- , Has sch schemas schema- , Has tab schema ('Table table)- , row0 ~ TableToRow table- , columns ~ TableToColumns table- , SOP.All (HasIn columns) subcolumns- , AllUnique subcolumns )- => QualifiedAlias sch tab -- ^ table to update- -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns- -- ^ modified values to replace old values- -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]- -- ^ condition under which to perform update on a row- -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return- -> Manipulation commons schemas params row1-update tab columns wh returning = UnsafeManipulation $- "UPDATE"- <+> renderSQL tab- <+> "SET"- <+> renderCommaSeparated renderUpdate columns- <+> "WHERE" <+> renderSQL wh- <> renderSQL returning---- | Update a row returning `Nil`.-update_- :: ( SOP.SListI columns- , db ~ (commons :=> schemas)- , Has sch schemas schema- , Has tab schema ('Table table)- , row ~ TableToRow table- , columns ~ TableToColumns table- , SOP.All (HasIn columns) subcolumns- , AllUnique subcolumns )- => QualifiedAlias sch tab -- ^ table to update- -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns- -- ^ modified values to replace old values- -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]- -- ^ condition under which to perform update on a row- -> Manipulation commons schemas params '[]-update_ tab columns wh = update tab columns wh (Returning_ Nil)--{------------------------------------------DELETE statements------------------------------------------}---- | Specify additional tables.-data UsingClause commons schemas params from where- -- | No `UsingClause`- NoUsing :: UsingClause commons schemas params '[]- -- | An `also` list of table expressions, allowing columns- -- from other tables to appear in the WHERE condition.- -- This is similar to the list of tables that can be specified- -- in the FROM Clause of a SELECT statement;- -- for example, an alias for the table name can be specified.- -- Do not repeat the target table in the `Using` list,- -- unless you wish to set up a self-join.+-- | Specify additional tables with `Using`+-- an `also` list of table expressions, allowing columns+-- from other tables to appear in the WHERE condition.+-- This is similar to the list of tables that can be specified+-- in the FROM Clause of a SELECT statement;+-- for example, an alias for the table name can be specified.+-- Do not repeat the target table in the `Using` list,+-- unless you wish to set up a self-join.+-- `NoUsing` if no additional tables are to be used.+data UsingClause with db params from where+ NoUsing :: UsingClause with db params '[] Using- :: FromClause '[] commons schemas params from- -> UsingClause commons schemas params from---- | Delete rows from a table.-deleteFrom- :: ( SOP.SListI row1- , db ~ (commons :=> schemas)- , Has sch schemas schema- , Has tab schema ('Table table)- , row0 ~ TableToRow table- , columns ~ TableToColumns table )- => QualifiedAlias sch tab -- ^ table to delete from- -> UsingClause commons schemas params from- -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)- -- ^ condition under which to delete a row- -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return- -> Manipulation commons schemas params row1-deleteFrom tab using wh returning = UnsafeManipulation $- "DELETE FROM"- <+> renderSQL tab- <> case using of- NoUsing -> ""- Using tables -> " USING" <+> renderSQL tables- <+> "WHERE" <+> renderSQL wh- <> renderSQL returning---- | Delete rows returning `Nil`.-deleteFrom_- :: ( db ~ (commons :=> schemas)- , Has sch schemas schema- , Has tab schema ('Table table)- , row ~ TableToRow table- , columns ~ TableToColumns table )- => QualifiedAlias sch tab -- ^ table to delete from- -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]- -- ^ condition under which to delete a row- -> Manipulation commons schemas params '[]-deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)+ :: FromClause '[] with db params from+ -- ^ what to use+ -> UsingClause with db params from
+ src/Squeal/PostgreSQL/Manipulation/Call.hs view
@@ -0,0 +1,118 @@+{-|+Module: Squeal.PostgreSQL.Call+Description: call statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++call statements+-}++{-# LANGUAGE+ DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PatternSynonyms+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Manipulation.Call+ ( -- * Call+ call+ , unsafeCall+ , callN+ , unsafeCallN+ ) where++import Data.ByteString hiding (foldr)++import Generics.SOP (SListI)++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- |+>>> printSQL $ unsafeCall "p" true+CALL p(TRUE)+-}+unsafeCall+ :: ByteString -- ^ procedure to call+ -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments+ -> Manipulation with db params '[]+unsafeCall pro x = UnsafeManipulation $+ "CALL" <+> pro <> parenthesized (renderSQL x)++{- | Call a user defined procedure of one variable.++>>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4 ] ]+>>> :{+let+ p :: Manipulation '[] (Public Schema) '[] '[]+ p = call #p 1+in+ printSQL p+:}+CALL "p"((1 :: int4))+-}+call+ :: ( Has sch db schema+ , Has pro schema ('Procedure '[x]) )+ => QualifiedAlias sch pro -- ^ procedure to call+ -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments+ -> Manipulation with db params '[]+call = unsafeCall . renderSQL+++{- |+>>> printSQL $ unsafeCallN "p" (true *: false)+CALL p(TRUE, FALSE)+-}+unsafeCallN+ :: SListI xs+ => ByteString -- ^ procedure to call+ -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments+ -> Manipulation with db params '[]+unsafeCallN pro xs = UnsafeManipulation $ + "CALL" <+> pro <> parenthesized (renderCommaSeparated renderSQL xs)++{- | Call a user defined procedure.++>>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] ]+>>> :{+let+ p :: Manipulation '[] (Public Schema) '[] '[]+ p = callN #p (1 *: "hi")+in+ printSQL p+:}+CALL "p"((1 :: int4), (E'hi' :: text))+-}+callN+ :: ( Has sch db schema+ , Has pro schema ('Procedure xs)+ , SListI xs )+ => QualifiedAlias sch pro -- ^ procedure to call+ -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments+ -> Manipulation with db params '[]+callN = unsafeCallN . renderSQL
+ src/Squeal/PostgreSQL/Manipulation/Delete.hs view
@@ -0,0 +1,106 @@+{-|+Module: Squeal.PostgreSQL.Delete+Description: delete statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++delete statements+-}++{-# LANGUAGE+ DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PatternSynonyms+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Manipulation.Delete+ ( -- * Delete+ deleteFrom+ , deleteFrom_+ ) where++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+DELETE statements+-----------------------------------------}++{- | Delete rows from a table.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ manp = deleteFrom #tab1 (Using (table #tab2)) (#tab1 ! #col1 .== #tab2 ! #col2) (Returning (#tab1 & DotStar))+in printSQL manp+:}+DELETE FROM "tab1" AS "tab1" USING "tab2" AS "tab2" WHERE ("tab1"."col1" = "tab2"."col2") RETURNING "tab1".*+-}+deleteFrom+ :: ( SOP.SListI row+ , Has sch db schema+ , Has tab0 schema ('Table table) )+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from+ -> UsingClause with db params from+ -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)+ -- ^ condition under which to delete a row+ -> ReturningClause with db params (tab ::: TableToRow table ': from) row+ -- ^ results to return+ -> Manipulation with db params row+deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $+ "DELETE FROM"+ <+> renderSQL tab0 <+> "AS" <+> renderSQL tab+ <> case using of+ NoUsing -> ""+ Using tables -> " USING" <+> renderSQL tables+ <+> "WHERE" <+> renderSQL wh+ <> renderSQL returning++{- | Delete rows returning `Nil`.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[]+ manp = deleteFrom_ (#tab `as` #t) (#t ! #col1 .== param @1)+in printSQL manp+:}+DELETE FROM "tab" AS "t" WHERE ("t"."col1" = ($1 :: int4))+-}+deleteFrom_+ :: ( Has sch db schema+ , Has tab0 schema ('Table table) )+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from+ -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table]+ -- ^ condition under which to delete a row+ -> Manipulation with db params '[]+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
+ src/Squeal/PostgreSQL/Manipulation/Insert.hs view
@@ -0,0 +1,289 @@+{-|+Module: Squeal.PostgreSQL.Manipulation.Insert+Description: insert statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++insert statements+-}++{-# LANGUAGE+ DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PatternSynonyms+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Manipulation.Insert+ ( -- * Insert+ insertInto+ , insertInto_+ -- * Clauses+ , QueryClause (..)+ , pattern Values_+ , inlineValues+ , inlineValues_+ , ConflictClause (..)+ , ConflictTarget (..)+ , ConflictAction (..)+ ) where++import Data.ByteString hiding (foldr)++import qualified Generics.SOP as SOP+import qualified Generics.SOP.Record as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Default+import Squeal.PostgreSQL.Expression.Inline+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Query.Table+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+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.++>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]+>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]+>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]+>>> :{+let+ manp :: Manipulation with (Public CustomersSchema) '[] '[]+ manp =+ insertInto #customers+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))+ (OnConflict (OnConstraint #uq)+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))+ (Returning_ Nil)+in printSQL manp+:}+INSERT INTO "customers" AS "customers" ("name", "email") VALUES ((E'John Smith' :: text), (E'john@smith.com' :: text)) ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || ((E'; ' :: text) || "customers"."email"))+-}+insertInto+ :: ( Has sch db schema+ , Has tab0 schema ('Table table)+ , SOP.SListI (TableToColumns table)+ , SOP.SListI row )+ => Aliased (QualifiedAlias sch) (tab ::: tab0)+ -- ^ table+ -> QueryClause with db params (TableToColumns table)+ -- ^ what to insert+ -> ConflictClause tab with db params table+ -- ^ what to do in case of conflict+ -> ReturningClause with db params '[tab ::: TableToRow table] row+ -- ^ what to return+ -> Manipulation with db params row+insertInto (tab0 `As` tab) qry conflict ret = UnsafeManipulation $+ "INSERT" <+> "INTO"+ <+> renderSQL tab0 <+> "AS" <+> renderSQL tab+ <+> renderSQL qry+ <> renderSQL conflict+ <> renderSQL ret++{- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.++>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[] '[]+ manp =+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))+in printSQL manp+:}+INSERT INTO "tab" AS "tab" ("col1", "col2") VALUES ((2 :: int4), DEFAULT)+-}+insertInto_+ :: ( Has sch db schema+ , Has tab0 schema ('Table table)+ , SOP.SListI (TableToColumns table) )+ => Aliased (QualifiedAlias sch) (tab ::: tab0)+ -- ^ table+ -> QueryClause with db params (TableToColumns table)+ -- ^ what to insert+ -> Manipulation with db params '[]+insertInto_ tab qry =+ insertInto tab qry OnConflictDoRaise (Returning_ Nil)++-- | A `QueryClause` describes what to `insertInto` a table.+data QueryClause with db params columns where+ Values+ :: SOP.SListI columns+ => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns+ -- ^ row of values+ -> [NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns]+ -- ^ additional rows of values+ -> QueryClause with db params columns+ Select+ :: SOP.SListI columns+ => NP (Aliased (Optional (Expression grp '[] with db params from))) columns+ -- ^ row of values+ -> TableExpression grp '[] with db params from+ -- ^ from a table expression+ -> QueryClause with db params columns+ Subquery+ :: ColumnsToRow columns ~ row+ => Query '[] with db params row+ -- ^ subquery to insert+ -> QueryClause with db params columns++instance RenderSQL (QueryClause with db params columns) where+ renderSQL = \case+ Values row0 rows ->+ parenthesized (renderCommaSeparated renderSQLPart row0)+ <+> "VALUES"+ <+> commaSeparated+ ( parenthesized+ . renderCommaSeparated renderValuePart <$> row0 : rows )+ Select row0 tab ->+ parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)+ <+> "SELECT"+ <+> renderCommaSeparatedMaybe renderValuePartMaybe row0+ <+> renderSQL tab+ Subquery qry -> renderQuery qry+ where+ renderSQLPartMaybe, renderValuePartMaybe+ :: Aliased (Optional (Expression grp '[] with db params from)) column+ -> Maybe ByteString+ renderSQLPartMaybe = \case+ Default `As` _ -> Nothing+ Set _ `As` name -> Just $ renderSQL name+ renderValuePartMaybe = \case+ Default `As` _ -> Nothing+ Set value `As` _ -> Just $ renderExpression value+ renderSQLPart, renderValuePart+ :: Aliased (Optional (Expression grp '[] with db params from)) column+ -> ByteString+ renderSQLPart (_ `As` name) = renderSQL name+ renderValuePart (value `As` _) = renderSQL value++-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s+-- whose `ColumnsType` must match the tables'.+pattern Values_+ :: SOP.SListI columns+ => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) columns+ -- ^ row of values+ -> QueryClause with db params columns+pattern Values_ vals = Values vals []++-- | `inlineValues_` a Haskell record in `insertInto`.+inlineValues_+ :: ( SOP.IsRecord hask xs+ , SOP.AllZip InlineColumn xs columns )+ => hask -- ^ record+ -> QueryClause with db params columns+inlineValues_ = Values_ . inlineColumns++-- | `inlineValues` Haskell records in `insertInto`.+inlineValues+ :: ( SOP.IsRecord hask xs+ , SOP.AllZip InlineColumn xs columns )+ => hask -- ^ record+ -> [hask] -- ^ more+ -> QueryClause with db params columns+inlineValues hask hasks = Values (inlineColumns hask) (inlineColumns <$> hasks)++-- | A `ConflictClause` specifies an action to perform upon a constraint+-- violation. `OnConflictDoRaise` will raise an error.+-- `OnConflict` `DoNothing` simply avoids inserting a row.+-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row+-- proposed for insertion.+data ConflictClause tab with db params table where+ OnConflictDoRaise :: ConflictClause tab with db params table+ OnConflict+ :: ConflictTarget table+ -- ^ conflict target+ -> ConflictAction tab with db params table+ -- ^ conflict action+ -> ConflictClause tab with db params table++-- | Render a `ConflictClause`.+instance SOP.SListI (TableToColumns table)+ => RenderSQL (ConflictClause tab with db params table) where+ renderSQL = \case+ OnConflictDoRaise -> ""+ OnConflict target action -> " ON CONFLICT"+ <+> renderSQL target <+> renderSQL action++{- |+`ConflictAction` specifies an alternative `OnConflict` action.+It can be either `DoNothing`, or a `DoUpdate` clause specifying+the exact details of the update action to be performed in case of a conflict.+The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the+existing row using the table's name, and to rows proposed+for insertion using the special @#excluded@ row.+`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.+`OnConflict` `DoUpdate` updates the existing row that conflicts+with the row proposed for insertion as its alternative action.+-}+data ConflictAction tab with db params table where+ DoNothing :: ConflictAction tab with db params table+ DoUpdate+ :: ( row ~ TableToRow table+ , from ~ '[tab ::: row, "excluded" ::: row]+ , Updatable table updates )+ => NP (Aliased (Optional (Expression 'Ungrouped '[] with db params from))) updates+ -> [Condition 'Ungrouped '[] with db params from]+ -- ^ WHERE `Condition`s+ -> ConflictAction tab with db params table++instance RenderSQL (ConflictAction tab with db params table) where+ renderSQL = \case+ DoNothing -> "DO NOTHING"+ DoUpdate updates whs'+ -> "DO UPDATE SET"+ <+> renderCommaSeparated renderUpdate updates+ <> case whs' of+ [] -> ""+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)++renderUpdate+ :: (forall x. RenderSQL (expr x))+ => Aliased (Optional expr) ty+ -> ByteString+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr++-- | A `ConflictTarget` specifies the constraint violation that triggers a+-- `ConflictAction`.+data ConflictTarget table where+ OnConstraint+ :: Has con constraints constraint+ => Alias con+ -> ConflictTarget (constraints :=> columns)++-- | Render a `ConflictTarget`+instance RenderSQL (ConflictTarget constraints) where+ renderSQL (OnConstraint con) =+ "ON" <+> "CONSTRAINT" <+> renderSQL con
+ src/Squeal/PostgreSQL/Manipulation/Update.hs view
@@ -0,0 +1,135 @@+{-|+Module: Squeal.PostgreSQL.Update+Description: update statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++update statements+-}++{-# LANGUAGE+ DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PatternSynonyms+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Manipulation.Update+ ( -- * Update+ update+ , update_+ ) where++import Data.ByteString hiding (foldr)+import GHC.TypeLits++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Default+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++renderUpdate+ :: (forall x. RenderSQL (expr x))+ => Aliased (Optional expr) ty+ -> ByteString+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr++{-----------------------------------------+UPDATE statements+-----------------------------------------}++{- | An `update` command changes the values of the specified columns+in all rows that satisfy the condition.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[]+ '["col1" ::: 'NotNull 'PGint4,+ "col2" ::: 'NotNull 'PGint4]+ manp = update+ (#tab1 `as` #t1)+ (Set (2 + #t2 ! #col2) `as` #col1)+ (Using (table (#tab2 `as` #t2)))+ (#t1 ! #col1 ./= #t2 ! #col2)+ (Returning (#t1 & DotStar))+in printSQL manp+:}+UPDATE "tab1" AS "t1" SET "col1" = ((2 :: int4) + "t2"."col2") FROM "tab2" AS "t2" WHERE ("t1"."col1" <> "t2"."col2") RETURNING "t1".*+-}+update+ :: ( Has sch db schema+ , Has tab0 schema ('Table table)+ , Updatable table updates+ , SOP.SListI row )+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update+ -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)))) updates+ -- ^ update expressions, modified values to replace old values+ -> UsingClause with db params from+ -- ^ FROM A table expression allowing columns from other tables to appear+ -- in the WHERE condition and update expressions.+ -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)+ -- ^ WHERE condition under which to perform update on a row+ -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return+ -> Manipulation with db params row+update (tab0 `As` tab) columns using wh returning = UnsafeManipulation $+ "UPDATE"+ <+> renderSQL tab0 <+> "AS" <+> renderSQL tab+ <+> "SET"+ <+> renderCommaSeparated renderUpdate columns+ <> case using of+ NoUsing -> ""+ Using tables -> " FROM" <+> renderSQL tables+ <+> "WHERE" <+> renderSQL wh+ <> renderSQL returning++{- | Update a row returning `Nil`.++>>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ manp :: Manipulation with (Public Schema) '[] '[]+ manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)+in printSQL manp+:}+UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2")+-}+update_+ :: ( Has sch db schema+ , Has tab0 schema ('Table table)+ , KnownSymbol tab+ , Updatable table updates )+ => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update+ -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[tab ::: TableToRow table]))) updates+ -- ^ modified values to replace old values+ -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table]+ -- ^ condition under which to perform update on a row+ -> Manipulation with db params '[]+update_ tab columns wh = update tab columns NoUsing wh (Returning_ Nil)
− src/Squeal/PostgreSQL/Migration.hs
@@ -1,446 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Migration-Description: Squeal migrations-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--This module defines a `Migration` type to safely-change the schema of your database over time. Let's see an example!--First turn on some extensions.-->>> :set -XDataKinds -XOverloadedLabels->>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators--Next, let's define our `TableType`s.-->>> :{-type UsersTable =- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- ]-:}-->>> :{-type EmailsTable =- '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4- , "email" ::: 'NoDef :=> 'Null 'PGtext- ]-:}--Now we can define some `Migration`s to make our tables.-->>> :{-let- makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]- makeUsers = Migration- { name = "make users table"- , up = createTable #users- ( serial `as` #id :*- notNullable text `as` #name )- ( primaryKey #id `as` #pk_users )- , down = dropTable #users- }-:}-->>> :{-let- makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]- '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]- makeEmails = Migration- { name = "make emails table"- , up = createTable #emails- ( serial `as` #id :*- notNullable int `as` #user_id :*- nullable text `as` #email )- ( primaryKey #id `as` #pk_emails :*- foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )- , down = dropTable #emails- }-:}--Now that we have a couple migrations we can chain them together into an `AlignedList`.-->>> let migrations = makeUsers :>> makeEmails :>> Done--Now run the migrations.-->>> import Control.Monad.IO.Class->>> :{-withConnection "host=localhost port=5432 dbname=exampledb" $- manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")- -- suppress notices- & pqThen (liftIO (putStrLn "Migrate"))- & pqThen (migrateUp migrations)- & pqThen (liftIO (putStrLn "Rollback"))- & pqThen (migrateDown migrations)-:}-Migrate-Rollback--We can also create a simple executable using `defaultMain`.-->>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations-->>> withArgs [] main-Invalid command: "". Use:-migrate to run all available migrations-rollback to rollback all available migrations-status to display migrations run and migrations left to run-->>> withArgs ["status"] main-Migrations already run:- None-Migrations left to run:- - make users table- - make emails table-->>> withArgs ["migrate"] main-Migrations already run:- - make users table- - make emails table-Migrations left to run:- None-->>> withArgs ["rollback"] main-Migrations already run:- None-Migrations left to run:- - make users table- - make emails table--In addition to enabling `Migration`s using pure SQL `Definition`s for-the `up` and `down` instructions, you can also perform impure `IO` actions-by using a `Migration`s over the `Terminally` `PQ` `IO` category.--}--{-# LANGUAGE- DataKinds- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , GADTs- , LambdaCase- , OverloadedLabels- , OverloadedStrings- , PolyKinds- , QuantifiedConstraints- , RankNTypes- , TypeApplications- , TypeOperators-#-}--module Squeal.PostgreSQL.Migration- ( -- * Migration- Migration (..)- , Migratory (..)- , Terminally (..)- , terminally- , pureMigration- , MigrationsTable- , defaultMain- ) where--import Control.Category-import Control.Monad-import Data.ByteString (ByteString)-import Data.Foldable (traverse_)-import Data.Function ((&))-import Data.List ((\\))-import Data.Text (Text)-import Data.Time (UTCTime)-import Prelude hiding ((.), id)-import System.Environment-import UnliftIO (MonadIO (..))--import qualified Data.Text.IO as Text (putStrLn)-import qualified Generics.SOP as SOP-import qualified GHC.Generics as GHC--import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.Binary-import Squeal.PostgreSQL.Definition-import Squeal.PostgreSQL.Expression.Comparison-import Squeal.PostgreSQL.Expression.Parameter-import Squeal.PostgreSQL.Expression.Time-import Squeal.PostgreSQL.Expression.Type-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Manipulation-import Squeal.PostgreSQL.PQ-import Squeal.PostgreSQL.Query-import Squeal.PostgreSQL.Schema-import Squeal.PostgreSQL.Transaction---- | A `Migration` is a named "isomorphism" over a given category.--- It should contain an inverse pair of `up` and `down`--- instructions and a unique `name`.-data Migration p schemas0 schemas1 = Migration- { name :: Text -- ^ The `name` of a `Migration`.- -- Each `name` in a `Migration` should be unique.- , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.- , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.- } deriving (GHC.Generic)--{- |-A `Migratory` @p@ is a `Category` for which one can execute or rewind-an `AlignedList` of `Migration`s over @p@. This includes the category of pure-SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.--}-class Category p => Migratory p where-- {- |- Run an `AlignedList` of `Migration`s.- Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.- In one transaction, for each each `Migration` query to see if the `Migration` has been executed;- if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.- -}- migrateUp- :: AlignedList (Migration p) schemas0 schemas1- -> PQ schemas0 schemas1 IO ()-- {- |- Rewind an `AlignedList` of `Migration`s.- Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.- In one transaction, for each each `Migration` query to see if the `Migration` has been executed;- if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.- -}- migrateDown- :: AlignedList (Migration p) schemas0 schemas1- -> PQ schemas1 schemas0 IO ()--instance Migratory Definition where- migrateUp = migrateUp . mapAligned pureMigration- migrateDown = migrateDown . mapAligned pureMigration--{- | `Terminally` turns an indexed monad transformer and the monad it transforms-into a category by restricting the return type to @()@ and permuting the type variables.-This is similar to how applying a monad to @()@ yields a monoid.-Since a `Terminally` action has a trivial return value, the only reason-to run one is for the side effects, in particular database and other IO effects.--}-newtype Terminally trans monad x0 x1 = Terminally- { runTerminally :: trans x0 x1 monad () }- deriving GHC.Generic--instance- ( IndexedMonadTransPQ trans- , Monad monad- , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )- => Category (Terminally trans monad) where- id = Terminally (return ())- Terminally g . Terminally f = Terminally $ pqThen g f---- | `terminally` ignores the output of a computation, returning @()@ and--- wrapping it up into a `Terminally`. You can lift an action in the base monad--- by using @terminally . lift@.-terminally- :: Functor (trans x0 x1 monad)- => trans x0 x1 monad ignore- -> Terminally trans monad x0 x1-terminally = Terminally . void---- | A `pureMigration` turns a `Migration` involving only pure SQL--- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.-pureMigration- :: Migration Definition schemas0 schemas1- -> Migration (Terminally PQ IO) schemas0 schemas1-pureMigration migration = Migration- { name = name migration- , up = terminally . define $ up migration- , down = terminally . define $ down migration- }--instance Migratory (Terminally PQ IO) where-- migrateUp migration = unsafePQ . transactionally_ $ do- define createMigrations- upMigrations migration-- where-- upMigrations- :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1- -> PQ MigrationsSchemas MigrationsSchemas IO ()- upMigrations = \case- Done -> return ()- step :>> steps -> upMigration step >> upMigrations steps-- upMigration- :: Migration (Terminally PQ IO) schemas0 schemas1- -> PQ MigrationsSchemas MigrationsSchemas IO ()- upMigration step = do- executed <- queryExecuted step- unless (executed == 1) $ do- unsafePQ . runTerminally $ up step- manipulateParams_ insertMigration (Only (name step))-- queryExecuted- :: Migration (Terminally PQ IO) schemas0 schemas1- -> PQ MigrationsSchemas MigrationsSchemas IO Row- queryExecuted step = do- result <- runQueryParams selectMigration (Only (name step))- ntuples result-- migrateDown migrations = unsafePQ . transactionally_ $ do- define createMigrations- downMigrations migrations-- where-- downMigrations- :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1- -> PQ MigrationsSchemas MigrationsSchemas IO ()- downMigrations = \case- Done -> return ()- step :>> steps -> downMigrations steps >> downMigration step-- downMigration- :: Migration (Terminally PQ IO) schemas0 schemas1- -> PQ MigrationsSchemas MigrationsSchemas IO ()- downMigration step = do- executed <- queryExecuted step- unless (executed == 0) $ do- unsafePQ . runTerminally $ down step- manipulateParams_ deleteMigration (Only (name step))-- queryExecuted- :: Migration (Terminally PQ IO) schemas0 schemas1- -> PQ MigrationsSchemas MigrationsSchemas IO Row- queryExecuted step = do- result <- runQueryParams selectMigration (Only (name step))- ntuples result--unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x-unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK---- | The `TableType` for a Squeal migration.-type MigrationsTable =- '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext- , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz- ]--data MigrationRow =- MigrationRow { migrationName :: Text- , migrationTime :: UTCTime }- deriving (GHC.Generic, Show)--instance SOP.Generic MigrationRow-instance SOP.HasDatatypeInfo MigrationRow--type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]-type MigrationsSchemas = Public MigrationsSchema---- | Creates a `MigrationsTable` if it does not already exist.-createMigrations :: Definition MigrationsSchemas MigrationsSchemas-createMigrations =- createTableIfNotExists #schema_migrations- ( (text & notNullable) `as` #name :*- (timestampWithTimeZone & notNullable & default_ currentTimestamp)- `as` #executed_at )- ( unique #name `as` #migrations_unique_name )---- | Inserts a `Migration` into the `MigrationsTable`, returning--- the time at which it was inserted.-insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()-insertMigration = insertInto_ #schema_migrations- (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))---- | Deletes a `Migration` from the `MigrationsTable`, returning--- the time at which it was inserted.-deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()-deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)---- | Selects a `Migration` from the `MigrationsTable`, returning--- the time at which it was inserted.-selectMigration- :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)-selectMigration = select_ (#executed_at `as` #fromOnly)- $ from (table (#schema_migrations))- & where_ (#name .== param @1)--selectMigrations :: Query_ MigrationsSchemas () MigrationRow-selectMigrations = select_- (#name `as` #migrationName :* #executed_at `as` #migrationTime)- (from (table #schema_migrations))--data MigrateCommand- = MigrateStatus- | MigrateUp- | MigrateDown deriving (GHC.Generic, Show)--{- | `defaultMain` creates a simple executable-from a connection string and a list of `Migration`s. -}-defaultMain- :: Migratory p- => ByteString- -- ^ connection string- -> AlignedList (Migration p) db0 db1- -- ^ migrations- -> IO ()-defaultMain connectTo migrations = do- command <- readCommandFromArgs- maybe (pure ()) performCommand command-- where-- performCommand :: MigrateCommand -> IO ()- performCommand = \case- MigrateStatus -> withConnection connectTo $- suppressNotices >> migrateStatus- MigrateUp -> withConnection connectTo $- suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus- MigrateDown -> withConnection connectTo $- suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus-- migrateStatus :: PQ schema schema IO ()- migrateStatus = unsafePQ $ do- runNames <- getRunMigrationNames- let names = extractList name migrations- unrunNames = names \\ runNames- liftIO $ displayRunned runNames >> displayUnrunned unrunNames-- suppressNotices :: PQ schema schema IO ()- suppressNotices = manipulate_ $- UnsafeManipulation "SET client_min_messages TO WARNING;"-- readCommandFromArgs :: IO (Maybe MigrateCommand)- readCommandFromArgs = getArgs >>= \case- ["migrate"] -> pure . Just $ MigrateUp- ["rollback"] -> pure . Just $ MigrateDown- ["status"] -> pure . Just $ MigrateStatus- args -> displayUsage args >> pure Nothing-- displayUsage :: [String] -> IO ()- displayUsage args = do- putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"- putStrLn "migrate to run all available migrations"- putStrLn "rollback to rollback all available migrations"- putStrLn "status to display migrations run and migrations left to run"-- getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]- getRunMigrationNames =- fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)-- displayListOfNames :: [Text] -> IO ()- displayListOfNames [] = Text.putStrLn " None"- displayListOfNames xs =- let singleName n = Text.putStrLn $ " - " <> n- in traverse_ singleName xs-- displayUnrunned :: [Text] -> IO ()- displayUnrunned unrunned =- Text.putStrLn "Migrations left to run:"- >> displayListOfNames unrunned-- displayRunned :: [Text] -> IO ()- displayRunned runned =- Text.putStrLn "Migrations already run:"- >> displayListOfNames runned
− src/Squeal/PostgreSQL/PG.hs
@@ -1,365 +0,0 @@-{-|-Module: Squeal.PostgreSQL.PG-Description: Embedding of Haskell types into Postgres's type system-Copyright: (c) Eitan Chatav, 2010-Maintainer: eitan@morphism.tech-Stability: experimental--`Squeal.PostgreSQL.PG` provides type families for turning Haskell-`Type`s into corresponding Postgres types.--}-{-# LANGUAGE- AllowAmbiguousTypes- , DeriveFoldable- , DeriveFunctor- , DeriveGeneric- , DeriveTraversable- , DefaultSignatures- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , LambdaCase- , OverloadedStrings- , MultiParamTypeClasses- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , TypeInType- , TypeOperators- , UndecidableInstances- , UndecidableSuperClasses-#-}--module Squeal.PostgreSQL.PG- ( -- * PG embeddings- PG- , NullPG- , TuplePG- , RowPG- -- * Storage newtypes- , Money (..)- , Json (..)- , Jsonb (..)- , Composite (..)- , Enumerated (..)- , VarArray (..)- , FixArray (..)- -- * Type families- , LabelsPG- , DimPG- , FixPG- , TupleOf- , TupleCodeOf- , RowOf- , ConstructorsOf- , ConstructorNameOf- , ConstructorNamesOf- ) where--import Data.Aeson (Value)-import Data.Kind (Type)-import Data.Int (Int16, Int32, Int64)-import Data.Scientific (Scientific)-import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)-import Data.Vector (Vector)-import Data.Word (Word16, Word32, Word64)-import Data.UUID.Types (UUID)-import GHC.TypeLits-import Network.IP.Addr (NetAddr, IP)--import qualified Data.ByteString.Lazy as Lazy (ByteString)-import qualified Data.ByteString as Strict (ByteString)-import qualified Data.Text.Lazy as Lazy (Text)-import qualified Data.Text as Strict (Text)-import qualified GHC.Generics as GHC-import qualified Generics.SOP as SOP-import qualified Generics.SOP.Record as SOP-import qualified Generics.SOP.Type.Metadata as Type--import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.Schema---- $setup--- >>> import Squeal.PostgreSQL--- >>> import Data.Text (Text)--{- | The `PG` type family embeds a subset of Haskell types-as Postgres types. As an open type family, `PG` is extensible.-->>> :kind! PG LocalTime-PG LocalTime :: PGType-= 'PGtimestamp-->>> newtype MyDouble = My Double->>> :set -XTypeFamilies->>> type instance PG MyDouble = 'PGfloat8--}-type family PG (hask :: Type) :: PGType--- | `PGbool`-type instance PG Bool = 'PGbool--- | `PGint2`-type instance PG Int16 = 'PGint2--- | `PGint4`-type instance PG Int32 = 'PGint4--- | `PGint8`-type instance PG Int64 = 'PGint8--- | `PGint2`-type instance PG Word16 = 'PGint2--- | `PGint4`-type instance PG Word32 = 'PGint4--- | `PGint8`-type instance PG Word64 = 'PGint8--- | `PGnumeric`-type instance PG Scientific = 'PGnumeric--- | `PGfloat4`-type instance PG Float = 'PGfloat4--- | `PGfloat8`-type instance PG Double = 'PGfloat8--- | `PGchar` @1@-type instance PG Char = 'PGchar 1--- | `PGtext`-type instance PG Strict.Text = 'PGtext--- | `PGtext`-type instance PG Lazy.Text = 'PGtext--- | `PGtext`-type instance PG String = 'PGtext--- | `PGbytea`-type instance PG Strict.ByteString = 'PGbytea--- | `PGbytea`-type instance PG Lazy.ByteString = 'PGbytea--- | `PGtimestamp`-type instance PG LocalTime = 'PGtimestamp--- | `PGtimestamptz`-type instance PG UTCTime = 'PGtimestamptz--- | `PGdate`-type instance PG Day = 'PGdate--- | `PGtime`-type instance PG TimeOfDay = 'PGtime--- | `PGtimetz`-type instance PG (TimeOfDay, TimeZone) = 'PGtimetz--- | `PGinterval`-type instance PG DiffTime = 'PGinterval--- | `PGuuid`-type instance PG UUID = 'PGuuid--- | `PGinet`-type instance PG (NetAddr IP) = 'PGinet--- | `PGjson`-type instance PG Value = 'PGjson--{-| The `LabelsPG` type family calculates the constructors of a-Haskell enum type.-->>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic->>> instance SOP.Generic Schwarma->>> instance SOP.HasDatatypeInfo Schwarma->>> :kind! LabelsPG Schwarma-LabelsPG Schwarma :: [Type.ConstructorName]-= '["Beef", "Lamb", "Chicken"]--}-type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where- LabelsPG hask =- ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))--{- |-`RowPG` turns a Haskell `Type` into a `RowType`.--`RowPG` may be applied to normal Haskell record types provided they-have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;-->>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic->>> instance SOP.Generic Person->>> instance SOP.HasDatatypeInfo Person->>> :kind! RowPG Person-RowPG Person :: [(Symbol, NullityType)]-= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]--}-type family RowPG (hask :: Type) :: RowType where- RowPG hask = RowOf (SOP.RecordCodeOf hask)---- | `RowOf` applies `NullPG` to the fields of a list.-type family RowOf (record :: [(Symbol, Type)]) :: RowType where- RowOf '[] = '[]- RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record--{- | `NullPG` turns a Haskell type into a `NullityType`.-->>> :kind! NullPG Double-NullPG Double :: NullityType-= 'NotNull 'PGfloat8->>> :kind! NullPG (Maybe Double)-NullPG (Maybe Double) :: NullityType-= 'Null 'PGfloat8--}-type family NullPG (hask :: Type) :: NullityType where- NullPG (Maybe hask) = 'Null (PG hask)- NullPG hask = 'NotNull (PG hask)--{- | `TuplePG` turns a Haskell tuple type (including record types) into-the corresponding list of `NullityType`s.-->>> :kind! TuplePG (Double, Maybe Char)-TuplePG (Double, Maybe Char) :: [NullityType]-= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]--}-type family TuplePG (hask :: Type) :: [NullityType] where- TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))---- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.-type family TupleOf (tuple :: [Type]) :: [NullityType] where- TupleOf '[] = '[]- TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple---- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`--- and if it's a simple product returns it, otherwise giving a `TypeError`.-type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where- TupleCodeOf hask '[tuple] = tuple- TupleCodeOf hask '[] =- TypeError- ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."- ':$$: 'Text "It is a void type with no constructors."- )- TupleCodeOf hask (_ ': _ ': _) =- TypeError- ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."- ':$$: 'Text "It is a sum type with more than one constructor."- )---- | Calculates constructors of a datatype.-type family ConstructorsOf (datatype :: Type.DatatypeInfo)- :: [Type.ConstructorInfo] where- ConstructorsOf ('Type.ADT _module _datatype constructors) =- constructors- ConstructorsOf ('Type.Newtype _module _datatype constructor) =- '[constructor]---- | Calculates the name of a nullary constructor, otherwise--- generates a type error.-type family ConstructorNameOf (constructor :: Type.ConstructorInfo)- :: Type.ConstructorName where- ConstructorNameOf ('Type.Constructor name) = name- ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError- ('Text "ConstructorNameOf error: non-nullary constructor "- ':<>: 'Text name)- ConstructorNameOf ('Type.Record name _fields) = TypeError- ('Text "ConstructorNameOf error: non-nullary constructor "- ':<>: 'Text name)---- | Calculate the names of nullary constructors.-type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])- :: [Type.ConstructorName] where- ConstructorNamesOf '[] = '[]- ConstructorNamesOf (constructor ': constructors) =- ConstructorNameOf constructor ': ConstructorNamesOf constructors---- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.-type family DimPG (hask :: Type) :: [Nat] where- DimPG (x,x) = 2 ': DimPG x- DimPG (x,x,x) = 3 ': DimPG x- DimPG (x,x,x,x) = 4 ': DimPG x- DimPG (x,x,x,x,x) = 5 ': DimPG x- DimPG (x,x,x,x,x,x) = 6 ': DimPG x- DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x- DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x- DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x- DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x- DimPG x = '[]---- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.-type family FixPG (hask :: Type) :: NullityType where- FixPG (x,x) = FixPG x- FixPG (x,x,x) = FixPG x- FixPG (x,x,x,x) = FixPG x- FixPG (x,x,x,x,x) = FixPG x- FixPG (x,x,x,x,x,x) = FixPG x- FixPG (x,x,x,x,x,x,x) = FixPG x- FixPG (x,x,x,x,x,x,x,x) = FixPG x- FixPG (x,x,x,x,x,x,x,x,x) = FixPG x- FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x- FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x- FixPG x = NullPG x--{- | The `Money` newtype stores a monetary value in terms-of the number of cents, i.e. @$2,000.20@ would be expressed as-@Money { cents = 200020 }@.-->>> import Control.Monad (void)->>> import Control.Monad.IO.Class (liftIO)->>> import Squeal.PostgreSQL->>> :{-let- roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)- roundTrip = values_ $ parameter @1 money `as` #fromOnly-:}-->>> let input = Only (Money 20020)-->>> :{-withConnection "host=localhost port=5432 dbname=exampledb" $ do- result <- runQueryParams roundTrip input- Just output <- firstRow result- liftIO . print $ input == output-:}-True--}-newtype Money = Money { cents :: Int64 }- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGmoney`-type instance PG Money = 'PGmoney--{- | The `Json` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGjson`.--}-newtype Json hask = Json {getJson :: hask}- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGjson`-type instance PG (Json hask) = 'PGjson--{- | The `Jsonb` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGjsonb`.--}-newtype Jsonb hask = Jsonb {getJsonb :: hask}- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGjsonb`-type instance PG (Jsonb hask) = 'PGjsonb--{- | The `Composite` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGcomposite`.--}-newtype Composite record = Composite {getComposite :: record}- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGcomposite` @(@`RowPG` @hask)@-type instance PG (Composite hask) = 'PGcomposite (RowPG hask)--{- | The `Enumerated` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGenum`.--}-newtype Enumerated enum = Enumerated {getEnumerated :: enum}- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGenum` @(@`LabelsPG` @hask)@-type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)--{- | The `VarArray` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGvararray`.-->>> :kind! PG (VarArray (Vector Double))-PG (VarArray (Vector Double)) :: PGType-= 'PGvararray ('NotNull 'PGfloat8)--}-newtype VarArray arr = VarArray {getVarArray :: arr}- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGvararray` @(@`NullPG` @hask)@-type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)-type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)--{- | The `FixArray` newtype is an indication that the Haskell-type it's applied to should be stored as a `PGfixarray`.-->>> :kind! PG (FixArray ((Double, Double), (Double, Double)))-PG (FixArray ((Double, Double), (Double, Double))) :: PGType-= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)--}-newtype FixArray arr = FixArray {getFixArray :: arr}- deriving (Eq, Ord, Show, Read, GHC.Generic)--- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@-type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
− src/Squeal/PostgreSQL/PQ.hs
@@ -1,688 +0,0 @@-{-|-Module: Squeal.PostgreSQL.PQ-Description: PQ monad-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--This module is where Squeal commands actually get executed by-`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing-a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,-and a `PQ` type with instances for them.--Using Squeal in your application will come down to defining-the @schemas@ of your database and including @PQ schemas schemas@ in your-application's monad transformer stack, giving it an instance of `MonadPQ`.--This module also provides functions for retrieving rows from the `LibPQ.Result`-of executing Squeal commands.--}--{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-{-# LANGUAGE- DefaultSignatures- , FunctionalDependencies- , FlexibleContexts- , FlexibleInstances- , InstanceSigs- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , TypeInType- , TypeOperators- , UndecidableInstances-#-}--module Squeal.PostgreSQL.PQ- ( -- * Connection- LibPQ.Connection- , connectdb- , finish- , withConnection- , lowerConnection- -- * PQ- , PQ (PQ, unPQ)- , runPQ- , execPQ- , evalPQ- , IndexedMonadTransPQ (..)- , MonadPQ (..)- -- * Results- , LibPQ.Result- , LibPQ.Row- , ntuples- , getRow- , getRows- , nextRow- , firstRow- , liftResult- , LibPQ.ExecStatus (..)- , resultStatus- , resultErrorMessage- , resultErrorCode- -- * Exceptions- , SquealException (..)- , PQState (..)- , okResult- , catchSqueal- , handleSqueal- , trySqueal- ) where--import Control.Exception (Exception, throw)-import Control.Monad.Except-import Control.Monad.Morph-import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)-import Data.ByteString (ByteString)-import Data.Foldable-import Data.Function ((&))-import Data.Kind-import Data.Text (pack, Text)-import Data.Traversable-import Generics.SOP-import PostgreSQL.Binary.Encoding (encodingBytes)--import qualified Control.Monad.Fail as Fail-import qualified Database.PostgreSQL.LibPQ as LibPQ--import Squeal.PostgreSQL.Binary-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 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---- $setup--- >>> import Squeal.PostgreSQL--{- | 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 -XPolyKinds->>> :set -XTypeOperators->>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> '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 schemas io- . MonadIO io- => ByteString -- ^ conninfo- -> io (K LibPQ.Connection schemas)-connectdb = fmap K . liftIO . LibPQ.connectdb---- | Closes the connection to the server.-finish :: MonadIO io => K LibPQ.Connection schemas -> io ()-finish = liftIO . LibPQ.finish . unK---- | Do `connectdb` and `finish` before and after a computation.-withConnection- :: forall schemas0 schemas1 io x- . MonadUnliftIO io- => ByteString- -> PQ schemas0 schemas1 io x- -> io x-withConnection connString action = do- K x <- bracket (connectdb connString) finish (unPQ action)- return x---- | Safely `lowerConnection` to a smaller schema.-lowerConnection- :: K LibPQ.Connection (schema ': schemas)- -> K LibPQ.Connection schemas-lowerConnection (K conn) = K conn---- | We keep track of the schema via an Atkey indexed state monad transformer,--- `PQ`.-newtype PQ- (schemas0 :: SchemasType)- (schemas1 :: SchemasType)- (m :: Type -> Type)- (x :: Type) =- PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }--instance Monad m => Functor (PQ schemas0 schemas1 m) where- fmap f (PQ pq) = PQ $ \ conn -> do- K x <- pq conn- return $ K (f x)---- | Run a `PQ` and keep the result and the `LibPQ.Connection`.-runPQ- :: Functor m- => PQ schemas0 schemas1 m x- -> K LibPQ.Connection schemas0- -> m (x, K LibPQ.Connection schemas1)-runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn- -- K x <- pq conn- -- return (x, K (unK conn))---- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.-execPQ- :: Functor m- => PQ schemas0 schemas1 m x- -> K LibPQ.Connection schemas0- -> m (K LibPQ.Connection schemas1)-execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn---- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.-evalPQ- :: Functor m- => PQ schemas0 schemas1 m x- -> K LibPQ.Connection schemas0- -> m x-evalPQ (PQ pq) conn = unK <$> pq conn---- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`--- [enriched category](https://ncatlab.org/nlab/show/enriched+category).--- An indexed monad transformer transforms a `Monad` into an indexed monad.--- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that--- support running `Definition`s using `define`.-class IndexedMonadTransPQ pq where-- -- | indexed analog of `<*>`- pqAp- :: Monad m- => pq schemas0 schemas1 m (x -> y)- -> pq schemas1 schemas2 m x- -> pq schemas0 schemas2 m y-- -- | indexed analog of `join`- pqJoin- :: Monad m- => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)- -> pq schemas0 schemas2 m y- pqJoin pq = pq & pqBind id-- -- | indexed analog of `=<<`- pqBind- :: Monad m- => (x -> pq schemas1 schemas2 m y)- -> pq schemas0 schemas1 m x- -> pq schemas0 schemas2 m y-- -- | indexed analog of flipped `>>`- pqThen- :: Monad m- => pq schemas1 schemas2 m y- -> pq schemas0 schemas1 m x- -> pq schemas0 schemas2 m y- pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)-- -- | indexed analog of `<=<`- pqAndThen- :: Monad m- => (y -> pq schemas1 schemas2 m z)- -> (x -> pq schemas0 schemas1 m y)- -> x -> pq schemas0 schemas2 m z- pqAndThen g f x = pqBind g (f x)-- -- | Run a `Definition` with `LibPQ.exec`.- --- -- It should be functorial in effect.- --- -- @define id = return ()@- -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@- define- :: MonadIO io- => Definition schemas0 schemas1- -> pq schemas0 schemas1 io ()--instance IndexedMonadTransPQ PQ where-- pqAp (PQ f) (PQ x) = PQ $ \ conn -> do- K f' <- f conn- K x' <- x (K (unK conn))- return $ K (f' x')-- pqBind f (PQ x) = PQ $ \ conn -> do- K x' <- x conn- unPQ (f x') (K (unK conn))-- define (UnsafeDefinition q) = PQ $ \ (K conn) -> do- resultMaybe <- liftIO $ LibPQ.exec conn q- case resultMaybe of- Nothing -> throw $ ResultException- "define: LibPQ.exec returned no results"- Just result -> K <$> okResult_ result--{- | `MonadPQ` is an @mtl@ style constraint, similar to-`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to--* `manipulateParams` runs a `Manipulation` with params from a type- with a `ToParams` constraint. It calls `LibPQ.execParams` and- doesn't afraid of anything.--* `manipulateParams_` is like `manipulateParams` for a returning-free statement.--* `manipulate` is like `manipulateParams` for a parameter-free statement.--* `manipulate_` is like `manipulate` for a returning-free statement.--* `runQueryParams` is like `manipulateParams` for query statements.--* `runQuery` is like `runQueryParams` for a parameter-free statement.--* `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 for a returning-free statement.--* `forPrepared_` is a flipped `traversePrepared_`.--* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection- into your monad.--To define an instance, you can minimally define only `manipulateParams`,-`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get-a default instance.---}-class Monad pq => MonadPQ schemas pq | pq -> schemas where- manipulateParams- :: ToParams x params- => Manipulation '[] schemas params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> x -> pq (K LibPQ.Result ys)- default manipulateParams- :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)- => ToParams x params- => Manipulation '[] schemas params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> x -> pq (K LibPQ.Result ys)- manipulateParams manipulation params = lift $- manipulateParams manipulation params-- manipulateParams_- :: ToParams x params- => Manipulation '[] schemas params '[]- -- ^ `insertInto`, `update` or `deleteFrom`- -> x -> pq ()- manipulateParams_ q x = void $ manipulateParams q x-- manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)- manipulate statement = manipulateParams statement ()-- manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()- manipulate_ = void . manipulate-- runQueryParams- :: ToParams x params- => Query '[] '[] schemas params ys- -- ^ `select` and friends- -> x -> pq (K LibPQ.Result ys)- runQueryParams = manipulateParams . queryStatement-- runQuery- :: Query '[] '[] schemas '[] ys- -- ^ `select` and friends- -> pq (K LibPQ.Result ys)- runQuery q = runQueryParams q ()-- traversePrepared- :: (ToParams x params, Traversable list)- => Manipulation '[] schemas params ys- -- ^ `insertInto`, `update`, or `deleteFrom`, and friends- -> list x -> pq (list (K LibPQ.Result ys))- default traversePrepared- :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)- => (ToParams x params, Traversable list)- => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))- traversePrepared manipulation params = lift $- traversePrepared manipulation params-- forPrepared- :: (ToParams x params, Traversable list)- => list x- -> Manipulation '[] schemas params ys- -- ^ `insertInto`, `update` or `deleteFrom`- -> pq (list (K LibPQ.Result ys))- forPrepared = flip traversePrepared-- traversePrepared_- :: (ToParams x params, Foldable list)- => Manipulation '[] schemas params '[]- -- ^ `insertInto`, `update` or `deleteFrom`- -> list x -> pq ()- default traversePrepared_- :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)- => (ToParams x params, Foldable list)- => Manipulation '[] schemas params '[]- -- ^ `insertInto`, `update` or `deleteFrom`- -> list x -> pq ()- traversePrepared_ manipulation params = lift $- traversePrepared_ manipulation params-- forPrepared_- :: (ToParams x params, Foldable list)- => list x- -> Manipulation '[] schemas params '[]- -- ^ `insertInto`, `update` or `deleteFrom`- -> pq ()- forPrepared_ = flip traversePrepared_-- liftPQ :: (LibPQ.Connection -> IO a) -> pq a- default liftPQ- :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)- => (LibPQ.Connection -> IO a) -> pq a- liftPQ = lift . liftPQ--instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)- => MonadPQ schemas (PQ schemas0 schemas1 io) where-- manipulateParams- (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =- PQ $ \ (K conn) -> do- let- toParam' encoding =- (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)- params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))- q' = q <> ";"- resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary- case resultMaybe of- Nothing -> throw $ ResultException- "manipulateParams: LibPQ.execParams returned no results"- Just result -> do- okResult_ result- return $ K (K result)-- traversePrepared- (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =- PQ $ \ (K conn) -> liftIO $ do- let temp = "temporary_statement"- prepResultMaybe <- LibPQ.prepare conn temp q Nothing- case prepResultMaybe of- Nothing -> throw $ ResultException- "traversePrepared: LibPQ.prepare returned no results"- Just prepResult -> okResult_ prepResult- results <- for list $ \ params -> do- let- toParam' encoding = (encodingBytes encoding,LibPQ.Binary)- params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))- resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary- case resultMaybe of- Nothing -> throw $ ResultException- "traversePrepared: LibPQ.execParams returned no results"- Just result -> do- okResult_ result- return $ K result- deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")- case deallocResultMaybe of- Nothing -> throw $ ResultException- "traversePrepared: LibPQ.exec DEALLOCATE returned no results"- Just deallocResult -> okResult_ deallocResult- return (K results)-- traversePrepared_- (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =- PQ $ \ (K conn) -> liftIO $ do- let temp = "temporary_statement"- prepResultMaybe <- LibPQ.prepare conn temp q Nothing- case prepResultMaybe of- Nothing -> throw $ ResultException- "traversePrepared_: LibPQ.prepare returned no results"- Just prepResult -> okResult_ prepResult- for_ list $ \ params -> do- let- toParam' encoding = (encodingBytes encoding, LibPQ.Binary)- params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))- resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary- case resultMaybe of- Nothing -> throw $ ResultException- "traversePrepared_: LibPQ.execParams returned no results"- Just result -> okResult_ result- deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")- case deallocResultMaybe of- Nothing -> throw $ ResultException- "traversePrepared: LibPQ.exec DEALLOCATE returned no results"- Just deallocResult -> okResult_ deallocResult- return (K ())-- liftPQ pq = PQ $ \ (K conn) -> do- y <- liftIO $ pq conn- return (K y)--instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)-instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)-instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)-instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)-instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)-instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)-instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)-instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)-instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)-instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)-instance MonadPQ schemas m => MonadPQ schemas (ContT r m)--instance (Monad m, schemas0 ~ schemas1)- => Applicative (PQ schemas0 schemas1 m) where- pure x = PQ $ \ _conn -> pure (K x)- (<*>) = pqAp--instance (Monad m, schemas0 ~ schemas1)- => Monad (PQ schemas0 schemas1 m) where- return = pure- (>>=) = flip pqBind--instance (Monad m, schemas0 ~ schemas1)- => Fail.MonadFail (PQ schemas0 schemas1 m) where- fail = Fail.fail--instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where- hoist f (PQ pq) = PQ (f . pq)--instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where- lift m = PQ $ \ _conn -> do- x <- m- return (K x)--instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where- embed f (PQ pq) = PQ $ \ conn -> do- evalPQ (f (pq conn)) conn--instance (MonadIO m, schema0 ~ schema1)- => MonadIO (PQ schema0 schema1 m) where- liftIO = lift . liftIO--instance (MonadUnliftIO m, schemas0 ~ schemas1)- => MonadUnliftIO (PQ schemas0 schemas1 m) where- withRunInIO- :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)- -> PQ schemas0 schema1 m b- withRunInIO inner = PQ $ \conn ->- withRunInIO $ \(run :: (forall x . m x -> IO x)) ->- K <$> inner (\pq -> run $ unK <$> unPQ pq conn)---- | Get a row corresponding to a given row number from a `LibPQ.Result`,--- throwing an exception if the row number is out of bounds.-getRow- :: (FromRow columns y, MonadIO io)- => LibPQ.Row- -- ^ row number- -> K LibPQ.Result columns- -- ^ result- -> io y-getRow r (K result :: K LibPQ.Result columns) = liftIO $ do- numRows <- LibPQ.ntuples result- when (numRows < r) $ throw $ ResultException $- "getRow: expected at least " <> pack (show r) <> "rows but only saw "- <> pack (show numRows)- let len = fromIntegral (lengthSList (Proxy @columns))- row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]- case fromList row' of- Nothing -> throw $ ResultException "getRow: found unexpected length"- Just row -> case fromRow @columns row of- Left parseError -> throw $ ParseException $ "getRow: " <> parseError- Right y -> return y---- | Intended to be used for unfolding in streaming libraries, `nextRow`--- takes a total number of rows (which can be found with `ntuples`)--- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,--- otherwise returning the row along with the next row number.-nextRow- :: (FromRow columns y, MonadIO io)- => LibPQ.Row -- ^ total number of rows- -> K LibPQ.Result columns -- ^ result- -> LibPQ.Row -- ^ row number- -> io (Maybe (LibPQ.Row,y))-nextRow total (K result :: K LibPQ.Result columns) r- = liftIO $ if r >= total then return Nothing else do- let len = fromIntegral (lengthSList (Proxy @columns))- row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]- case fromList row' of- Nothing -> throw $ ResultException "nextRow: found unexpected length"- Just row -> case fromRow @columns row of- Left parseError -> throw $ ParseException $ "nextRow: " <> parseError- Right y -> return $ Just (r+1, y)---- | Get all rows from a `LibPQ.Result`.-getRows- :: (FromRow columns y, MonadIO io)- => K LibPQ.Result columns -- ^ result- -> io [y]-getRows (K result :: K LibPQ.Result columns) = liftIO $ do- let len = fromIntegral (lengthSList (Proxy @columns))- numRows <- LibPQ.ntuples result- for [0 .. numRows - 1] $ \ r -> do- row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]- case fromList row' of- Nothing -> throw $ ResultException "getRows: found unexpected length"- Just row -> case fromRow @columns row of- Left parseError -> throw $ ParseException $ "getRows: " <> parseError- Right y -> return y---- | Get the first row if possible from a `LibPQ.Result`.-firstRow- :: (FromRow columns y, MonadIO io)- => K LibPQ.Result columns -- ^ result- -> io (Maybe y)-firstRow (K result :: K LibPQ.Result columns) = liftIO $ do- numRows <- LibPQ.ntuples result- if numRows <= 0 then return Nothing else do- let len = fromIntegral (lengthSList (Proxy @columns))- row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]- case fromList row' of- Nothing -> throw $ ResultException "firstRow: found unexpected length"- Just row -> case fromRow @columns row of- Left parseError -> throw $ ParseException $ "firstRow: " <> parseError- Right y -> return $ Just y---- | Lifts actions on results from @LibPQ@.-liftResult- :: MonadIO io- => (LibPQ.Result -> IO x)- -> K LibPQ.Result results -> io x-liftResult f (K result) = liftIO $ f result---- | Returns the number of rows (tuples) in the query result.-ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row-ntuples = liftResult LibPQ.ntuples---- | Returns the result status of the command.-resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus-resultStatus = liftResult LibPQ.resultStatus---- | Returns the error message most recently generated by an operation--- on the connection.-resultErrorMessage- :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)-resultErrorMessage = liftResult LibPQ.resultErrorMessage---- | Returns the error code most recently generated by an operation--- on the connection.------ https://www.postgresql.org/docs/current/static/errcodes-appendix.html-resultErrorCode- :: MonadIO io- => K LibPQ.Result results- -> io (Maybe ByteString)-resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)---- | the state of LibPQ-data PQState = PQState- { sqlExecStatus :: LibPQ.ExecStatus- , sqlStateCode :: Maybe ByteString- -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html- , sqlErrorMessage :: Maybe ByteString- } deriving (Eq, Show)---- | `Exception`s that can be thrown by Squeal.-data SquealException- = PQException PQState- | ResultException Text- | ParseException Text- deriving (Eq, Show)-instance Exception SquealException--okResult_ :: MonadIO io => LibPQ.Result -> io ()-okResult_ result = liftIO $ do- status <- LibPQ.resultStatus result- case status of- LibPQ.CommandOk -> return ()- LibPQ.TuplesOk -> return ()- _ -> do- stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate- msg <- LibPQ.resultErrorMessage result- throw . PQException $ PQState status stateCode msg---- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`--- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.-okResult :: MonadIO io => K LibPQ.Result row -> io ()-okResult = okResult_ . unK---- | Catch `SquealException`s.-catchSqueal- :: MonadUnliftIO io- => io a- -> (SquealException -> io a) -- ^ handler- -> io a-catchSqueal = catch---- | Handle `SquealException`s.-handleSqueal- :: MonadUnliftIO io- => (SquealException -> io a) -- ^ handler- -> io a -> io a-handleSqueal = handle---- | `Either` return a `SquealException` or a result.-trySqueal- :: MonadUnliftIO io- => io a- -> io (Either SquealException a)-trySqueal = try
− src/Squeal/PostgreSQL/Pool.hs
@@ -1,122 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Pool-Description: Connection pools-Copyright: (c) Eitan Chatav, 2017-Maintainer: eitan@morphism.tech-Stability: experimental--Connection pools.--Typical use case would be to create your pool using `createConnectionPool`-and run anything that requires the pool connection with `usingConnectionPool`.--Here's a simplified example:-->>> import Squeal.PostgreSQL-->>> :{-do- let- query :: Query_ (Public '[]) () (Only Char)- query = values_ (literal 'a' `as` #fromOnly)- pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10- chr <- usingConnectionPool pool $ do- result <- runQuery query- Just (Only a) <- firstRow result- return a- destroyConnectionPool pool- putChar chr-:}-a--}--{-# LANGUAGE- DeriveFunctor- , FlexibleContexts- , FlexibleInstances- , InstanceSigs- , MultiParamTypeClasses- , RankNTypes- , ScopedTypeVariables- , TypeFamilies- , TypeInType- , UndecidableInstances-#-}--module Squeal.PostgreSQL.Pool- ( -- * Pools- Pool- , createConnectionPool- , usingConnectionPool- , destroyConnectionPool- ) where--import Data.ByteString-import Data.Time-import Generics.SOP (K(..), unK)-import UnliftIO (MonadUnliftIO (..))-import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)--import Squeal.PostgreSQL.PQ---- | Create a striped pool of connections.--- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.-createConnectionPool- :: MonadUnliftIO io- => ByteString- -- ^ The passed string can be empty to use all default parameters, or it can- -- contain one or more parameter settings separated by whitespace.- -- 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 \.- -> Int- -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.- -> NominalDiffTime- -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.- -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.- -> Int- -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.- -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.- -> io (Pool (K Connection schemas))-createConnectionPool conninfo stripes idle maxResrc =- createPool (connectdb conninfo) finish stripes idle maxResrc--{-|-Temporarily take a connection from a `Pool`, perform an action with it,-and return it to the pool afterwards.--If the pool has an idle connection available, it is used immediately.-Otherwise, if the maximum number of connections has not yet been reached,-a new connection is created and used.-If the maximum number of connections has been reached, this function blocks-until a connection becomes available.--}-usingConnectionPool- :: MonadUnliftIO io- => Pool (K Connection schemas) -- ^ pool- -> PQ schemas schemas io x -- ^ session- -> io x-usingConnectionPool pool (PQ session) = unK <$> withResource pool session--{- |-Destroy all connections in all stripes in the pool.-Note that this will ignore any exceptions in the destroy function.--This function is useful when you detect that all connections-in the pool are broken. For example after a database has been-restarted all connections opened before the restart will be broken.-In that case it's better to close those connections so that-`usingConnectionPool` won't take a broken connection from the pool-but will open a new connection instead.--Another use-case for this function is that when you know you are done-with the pool you can destroy all idle connections immediately-instead of waiting on the garbage collector to destroy them,-thus freeing up those connections sooner.--}-destroyConnectionPool- :: MonadUnliftIO io- => Pool (K Connection schemas) -- ^ pool- -> io ()-destroyConnectionPool = destroyAllResources
src/Squeal/PostgreSQL/Query.hs view
@@ -1,16 +1,17 @@ {-| Module: Squeal.PostgreSQL.Query-Description: Squeal queries+Description: structured query language Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Squeal queries.+structured query language -} {-# LANGUAGE ConstraintKinds , DeriveGeneric+ , DerivingStrategies , FlexibleContexts , FlexibleInstances , GADTs@@ -24,25 +25,17 @@ , StandaloneDeriving , TypeApplications , TypeFamilies- , TypeInType+ , DataKinds+ , PolyKinds , TypeOperators , RankNTypes , UndecidableInstances #-} module Squeal.PostgreSQL.Query- ( -- * Queries- Query_- , Query (..)- -- ** Select- , select- , select_- , selectDistinct- , selectDistinct_- , Selection (..)- -- ** Values- , values- , values_+ ( -- * Query+ Query (..)+ , Query_ -- ** Set Operations , union , unionAll@@ -50,54 +43,17 @@ , intersectAll , except , exceptAll- -- ** With- , With (..)- , CommonTableExpression (..)- , withRecursive- -- * Table Expressions- , TableExpression (..)- , from- , where_- , groupBy- , having- , limit- , offset- -- * From Clauses- , FromClause (..)- , table- , subquery- , view- , common- , crossJoin- , innerJoin- , leftOuterJoin- , rightOuterJoin- , fullOuterJoin- -- * Grouping- , By (..)- , GroupByClause (..)- , HavingClause (..) ) where import Control.DeepSeq import Data.ByteString (ByteString) import Data.Kind (Type)-import Data.String-import Data.Word-import Generics.SOP hiding (from)-import GHC.TypeLits import qualified GHC.Generics as GHC -import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.Expression-import Squeal.PostgreSQL.Expression.Logic-import Squeal.PostgreSQL.Expression.Sort-import Squeal.PostgreSQL.Expression.Window-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.PG+import Squeal.PostgreSQL.Type.PG import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.Schema+import Squeal.PostgreSQL.Type.Schema -- $setup -- >>> import Squeal.PostgreSQL@@ -112,44 +68,13 @@ The general `Query` type is parameterized by -* @outer :: FromType@ - outer scope for a correlated subquery,-* @commons :: FromType@ - scope for all `common` table expressions,-* @schemas :: SchemasType@ - scope for all `table`s and `view`s,-* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,+* @lat :: FromType@ - scope for `Squeal.PostgreSQL.Query.From.Join.JoinLateral` and subquery expressions,+* @with :: FromType@ - scope for all `Squeal.PostgreSQL.Query.From.common` table expressions,+* @db :: SchemasType@ - scope for all `Squeal.PostgreSQL.Query.From.table`s and `Squeal.PostgreSQL.Query.From.view`s,+* @params :: [NullType]@ - scope for all `Squeal.Expression.Parameter.parameter`s, * @row :: RowType@ - return type of the `Query`.--}-newtype Query- (outer :: FromType)- (commons :: FromType)- (schemas :: SchemasType)- (params :: [NullityType])- (row :: RowType)- = UnsafeQuery { renderQuery :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery -{- |-The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,-against which the query is type-checked, an input @parameters@ Haskell `Type`,-and an ouput row Haskell `Type`.--A top-level query can be run-using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@-using `Squeal.PostgreSQL.PQ.runQuery`.--Generally, @parameters@ will be a Haskell tuple or record whose entries-may be referenced using positional-`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a-Haskell record, whose entries will be targeted using overloaded labels.--Let's see some examples of queries.-->>> :set -XDeriveAnyClass -XDerivingStrategies->>> :{-data Row a b = Row { col1 :: a, col2 :: b }- deriving stock (GHC.Generic)- deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)-:}+Let's see some `Query` examples. simple query: @@ -157,9 +82,9 @@ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)] >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab))-in printSQL query+ qry :: Query lat with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab))+in printSQL qry :} SELECT * FROM "tab" AS "tab" @@ -167,23 +92,23 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query =+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2) ( from (table #tab) & where_ (#col1 .> #col2) & where_ (#col2 .> 0) )-in printSQL query+in printSQL qry :}-SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))+SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > (0 :: int4))) subquery: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))-in printSQL query+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))+in printSQL qry :} SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub" @@ -191,9 +116,9 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)-in printSQL query+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)+in printSQL qry :} SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4 @@ -201,9 +126,9 @@ >>> :{ let- query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)- query = select Star (from (table #tab) & where_ (#col1 .> param @1))-in printSQL query+ qry :: Query '[] with (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab) & where_ (#col1 .> param @1))+in printSQL qry :} SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4)) @@ -211,23 +136,23 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int64 Int32)- query =+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint8, "col2" ::: 'NotNull 'PGint4]+ qry = select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2) ( from (table (#tab `as` #table1)) & groupBy #col1 & having (sum_ (Distinct #col2) .> 1) )-in printSQL query+in printSQL qry :}-SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)+SELECT COALESCE(sum(ALL "col2"), (0 :: int8)) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > (1 :: int8)) sorted query: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab) & orderBy [#col1 & Asc])-in printSQL query+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab) & orderBy [#col1 & Asc])+in printSQL qry :} SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC @@ -244,8 +169,8 @@ >>> :{ type OrdersConstraints = '["pk_orders" ::: PrimaryKey '["id"]- ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]- ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]+ ,"fk_customers" ::: ForeignKey '["customer_id"] "public" "customers" '["id"]+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "public" "shippers" '["id"] ] :} >>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]@@ -259,19 +184,17 @@ :} >>> :{-data Order = Order- { price :: Float- , customerName :: Text- , shipperName :: Text- } deriving GHC.Generic-instance SOP.Generic Order-instance SOP.HasDatatypeInfo Order+type OrderRow =+ '[ "price" ::: 'NotNull 'PGfloat4+ , "customerName" ::: 'NotNull 'PGtext+ , "shipperName" ::: 'NotNull 'PGtext+ ] :} >>> :{ let- query :: Query_ (Public OrdersSchema) () Order- query = select_+ qry :: Query lat with (Public OrdersSchema) params OrderRow+ qry = select_ ( #o ! #price `as` #price :* #c ! #name `as` #customerName :* #s ! #name `as` #shipperName )@@ -280,7 +203,7 @@ (#o ! #customer_id .== #c ! #id) & innerJoin (table (#shippers `as` #s)) (#o ! #shipper_id .== #s ! #id)) )-in printSQL query+in printSQL qry :} SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id") @@ -288,11 +211,11 @@ >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))-in printSQL query+in printSQL qry :} SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2" @@ -300,77 +223,140 @@ >>> :{ let- query :: Query_ schemas () (Row String Bool)- query = values+ qry :: Query lat with db params '["col1" ::: 'NotNull 'PGtext, "col2" ::: 'NotNull 'PGbool]+ qry = values ("true" `as` #col1 :* true `as` #col2) ["false" `as` #col1 :* false `as` #col2]-in printSQL query+in printSQL qry :}-SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")+SELECT * FROM (VALUES ((E'true' :: text), TRUE), ((E'false' :: text), FALSE)) AS t ("col1", "col2") set operations: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))-in printSQL query+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))+in printSQL qry :} (SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab") -with queries:+with query: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int32)- query = with (+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = with ( select Star (from (table #tab)) `as` #cte1 :>> select Star (from (common #cte1)) `as` #cte2 ) (select Star (from (common #cte2)))-in printSQL query+in printSQL qry :} WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2" -window function queries+window functions: >>> :{ let- query :: Query_ (Public Schema) () (Row Int32 Int64)- query = select+ qry :: Query '[] with (Public Schema) db '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint8]+ qry = select (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc]))) (from (table #tab))-in printSQL query+in printSQL qry :} SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab" -correlated subqueries+correlated subqueries: >>> :{ let- query :: Query_ (Public Schema) () (Only Int32)- query =- select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))+ qry :: Query '[] with (Public Schema) params '["col1" ::: 'NotNull 'PGint4]+ qry =+ select #col1 (from (table (#tab `as` #t1)) & where_ (exists ( select Star (from (table (#tab `as` #t2)) & where_ (#t2 ! #col2 .== #t1 ! #col1)))))-in printSQL query+in printSQL qry :}-SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))+SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))+-}+newtype Query+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (row :: RowType)+ = UnsafeQuery { renderQuery :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (Query lat with db params row) where renderSQL = renderQuery +{- |+The `Query_` type is parameterized by a @db@ `SchemasType`,+against which the query is type-checked, an input @params@ Haskell `Type`,+and an ouput row Haskell `Type`.++A `Query_` can be run+using `Squeal.PostgreSQL.Session.runQueryParams`, or if @params = ()@+using `Squeal.PostgreSQL.Session.runQuery`.++Generally, @params@ will be a Haskell tuple or record whose entries+may be referenced using positional+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a+Haskell record, whose entries will be targeted using overloaded labels.++`Query_` is a type family which resolves into a `Query`,+so don't be fooled by the input params and output row Haskell `Type`s,+which are converted into appropriate+Postgres @[@`NullType`@]@ params and `RowType` rows.+Use `Squeal.PostgreSQL.Session.Statement.query` to+fix actual Haskell input params and output rows.++>>> :set -XDeriveAnyClass -XDerivingStrategies+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint8, "col2" ::: 'Def :=> 'NotNull 'PGtext]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+data Row = Row { col1 :: Maybe Int64, col2 :: String }+ deriving stock (GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :{+let+ qry :: Query_ (Public Schema) (Int64, Bool) Row+ qry = select Star (from (table #tab) & where_ (#col1 .> param @1 .&& just_ (param @2)))+ stmt :: Statement (Public Schema) (Int64, Bool) Row+ stmt = query qry+:}++>>> :type qry+qry+ :: Query+ '[]+ '[]+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ '[ 'NotNull 'PGint8, 'NotNull 'PGbool]+ '["col1" ::: 'Null 'PGint8, "col2" ::: 'NotNull 'PGtext]+>>> :type stmt+stmt+ :: Statement+ '["public" ::: '["tab" ::: 'Table ('[] :=> Columns)]]+ (Int64, Bool)+ Row -} type family Query_- (schemas :: SchemasType)- (parameters :: Type)+ (db :: SchemasType)+ (params :: Type) (row :: Type) where- Query_ schemas params row =- Query '[] '[] schemas (TuplePG params) (RowPG row)+ Query_ db params row =+ Query '[] '[] db (TuplePG params) (RowPG row) -- | The results of two queries can be combined using the set operation -- `union`. Duplicate rows are eliminated. union- :: Query outer commons schemas params columns- -> Query outer commons schemas params columns- -> Query outer commons schemas params columns+ :: Query lat with db params columns -- ^+ -> Query lat with db params columns+ -> Query lat with db params columns q1 `union` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "UNION"@@ -379,9 +365,9 @@ -- | The results of two queries can be combined using the set operation -- `unionAll`, the disjoint union. Duplicate rows are retained. unionAll- :: Query outer commons schemas params columns- -> Query outer commons schemas params columns- -> Query outer commons schemas params columns+ :: Query lat with db params columns -- ^+ -> Query lat with db params columns+ -> Query lat with db params columns q1 `unionAll` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "UNION" <+> "ALL"@@ -390,9 +376,9 @@ -- | The results of two queries can be combined using the set operation -- `intersect`, the intersection. Duplicate rows are eliminated. intersect- :: Query outer commons schemas params columns- -> Query outer commons schemas params columns- -> Query outer commons schemas params columns+ :: Query lat with db params columns -- ^+ -> Query lat with db params columns+ -> Query lat with db params columns q1 `intersect` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "INTERSECT"@@ -401,9 +387,9 @@ -- | The results of two queries can be combined using the set operation -- `intersectAll`, the intersection. Duplicate rows are retained. intersectAll- :: Query outer commons schemas params columns- -> Query outer commons schemas params columns- -> Query outer commons schemas params columns+ :: Query lat with db params columns -- ^+ -> Query lat with db params columns+ -> Query lat with db params columns q1 `intersectAll` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "INTERSECT" <+> "ALL"@@ -412,9 +398,9 @@ -- | The results of two queries can be combined using the set operation -- `except`, the set difference. Duplicate rows are eliminated. except- :: Query outer commons schemas params columns- -> Query outer commons schemas params columns- -> Query outer commons schemas params columns+ :: Query lat with db params columns -- ^+ -> Query lat with db params columns+ -> Query lat with db params columns q1 `except` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "EXCEPT"@@ -423,624 +409,10 @@ -- | The results of two queries can be combined using the set operation -- `exceptAll`, the set difference. Duplicate rows are retained. exceptAll- :: Query outer commons schemas params columns- -> Query outer commons schemas params columns- -> Query outer commons schemas params columns+ :: Query lat with db params columns -- ^+ -> Query lat with db params columns+ -> Query lat with db params columns q1 `exceptAll` q2 = UnsafeQuery $ parenthesized (renderSQL q1) <+> "EXCEPT" <+> "ALL" <+> parenthesized (renderSQL q2)--{------------------------------------------SELECT queries------------------------------------------}--{- | The simplest kinds of `Selection` are `Star` and `DotStar` which-emits all columns that a `TableExpression` produces. A select `List`-is a list of `Expression`s. A `Selection` could be a list of-`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can-be selected with `Also`.--}-data Selection outer commons grp schemas params from row where- Star- :: HasUnique tab from row- => Selection outer commons 'Ungrouped schemas params from row- -- ^ `HasUnique` table in the `FromClause`- DotStar- :: Has tab from row- => Alias tab- -- ^ `Has` table with `Alias`- -> Selection outer commons 'Ungrouped schemas params from row- List- :: SListI row- => NP (Aliased (Expression outer commons grp schemas params from)) row- -- ^ `NP` list of `Aliased` `Expression`s- -> Selection outer commons grp schemas params from row- Over- :: SListI row- => NP (Aliased (WindowFunction outer commons grp schemas params from)) row- -- ^ `NP` list of `Aliased` `WindowFunction`s- -> WindowDefinition outer commons grp schemas params from- -> Selection outer commons grp schemas params from row- Also- :: Selection outer commons grp schemas params from right- -- ^ `Additional` `Selection`- -> Selection outer commons grp schemas params from left- -> Selection outer commons grp schemas params from (Join left right)-instance Additional (Selection outer commons grp schemas params from) where- also = Also-instance (KnownSymbol col, row ~ '[col ::: ty])- => Aliasable col- (Expression outer commons grp schemas params from ty)- (Selection outer commons grp schemas params from row) where- expr `as` col = List (expr `as` col)-instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])- => IsQualified tab col- (Selection outer commons 'Ungrouped schemas params from row1) where- tab ! col = tab ! col `as` col-instance- ( Has tab (Join outer from) row0- , Has col row0 ty- , row1 ~ '[col ::: ty]- , GroupedBy tab col bys )- => IsQualified tab col- (Selection outer commons ('Grouped bys) schemas params from row1) where- tab ! col = tab ! col `as` col-instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])- => IsLabel col- (Selection outer commons 'Ungrouped schemas params from row1) where- fromLabel = fromLabel @col `as` Alias-instance- ( HasUnique tab (Join outer from) row0- , Has col row0 ty- , row1 ~ '[col ::: ty]- , GroupedBy tab col bys )- => IsLabel col- (Selection outer commons ('Grouped bys) schemas params from row1) where- fromLabel = fromLabel @col `as` Alias--instance RenderSQL (Selection outer commons grp schemas params from row) where- renderSQL = \case- List list -> renderCommaSeparated (renderAliased renderSQL) list- Star -> "*"- DotStar tab -> renderSQL tab <> ".*"- Also right left -> renderSQL left <> ", " <> renderSQL right- Over winFns winDef ->- let- renderOver- :: Aliased (WindowFunction outer commons grp schemas params from) field- -> ByteString- renderOver (winFn `As` col) = renderSQL winFn- <+> "OVER" <+> parenthesized (renderSQL winDef)- <+> "AS" <+> renderSQL col- in- renderCommaSeparated renderOver winFns--instance IsString- (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where- fromString str = fromString str `as` Alias---- | the `TableExpression` in the `select` command constructs an intermediate--- virtual table by possibly combining tables, views, eliminating rows,--- grouping, etc. This table is finally passed on to processing by--- the select list. The `Selection` determines which columns of--- the intermediate table are actually output.-select- :: (SListI row, row ~ (x ': xs))- => Selection outer commons grp schemas params from row- -- ^ selection- -> TableExpression outer commons grp schemas params from- -- ^ intermediate virtual table- -> Query outer commons schemas params row-select selection tabexpr = UnsafeQuery $- "SELECT"- <+> renderSQL selection- <+> renderSQL tabexpr---- | Like `select` but takes an `NP` list of `Expression`s instead--- of a general `Selection`.-select_- :: (SListI row, row ~ (x ': xs))- => NP (Aliased (Expression outer commons grp schemas params from)) row- -- ^ select list- -> TableExpression outer commons grp schemas params from- -- ^ intermediate virtual table- -> Query outer commons schemas params row-select_ = select . List---- | After the select list has been processed, the result table can--- be subject to the elimination of duplicate rows using `selectDistinct`.-selectDistinct- :: (SListI columns, columns ~ (col ': cols))- => Selection outer commons 'Ungrouped schemas params from columns- -- ^ selection- -> TableExpression outer commons 'Ungrouped schemas params from- -- ^ intermediate virtual table- -> Query outer commons schemas params columns-selectDistinct selection tabexpr = UnsafeQuery $- "SELECT DISTINCT"- <+> renderSQL selection- <+> renderSQL tabexpr---- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead--- of a general `Selection`.-selectDistinct_- :: (SListI columns, columns ~ (col ': cols))- => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns- -- ^ select list- -> TableExpression outer commons 'Ungrouped schemas params from- -- ^ intermediate virtual table- -> Query outer commons schemas params columns-selectDistinct_ = selectDistinct . List---- | `values` computes a row value or set of row values--- specified by value expressions. It is most commonly used--- to generate a “constant table” within a larger command,--- but it can be used on its own.------ >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]--- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row--- >>> printSQL query--- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")-values- :: SListI cols- => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols- -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]- -- ^ When more than one row is specified, all the rows must- -- must have the same number of elements- -> Query outer commons schemas params cols-values rw rws = UnsafeQuery $ "SELECT * FROM"- <+> parenthesized (- "VALUES"- <+> commaSeparated- ( parenthesized- . renderCommaSeparated renderValuePart <$> rw:rws )- ) <+> "AS t"- <+> parenthesized (renderCommaSeparated renderAliasPart rw)- where- renderAliasPart, renderValuePart- :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString- renderAliasPart (_ `As` name) = renderSQL name- renderValuePart (value `As` _) = renderSQL value---- | `values_` computes a row value or set of row values--- specified by value expressions.-values_- :: SListI cols- => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols- -- ^ one row of values- -> Query outer commons schemas params cols-values_ rw = values rw []--{------------------------------------------Table Expressions------------------------------------------}---- | A `TableExpression` computes a table. The table expression contains--- a `fromClause` that is optionally followed by a `whereClause`,--- `groupByClause`, `havingClause`, `orderByClause`, `limitClause`--- and `offsetClause`s. Trivial table expressions simply refer--- to a table on disk, a so-called base table, but more complex expressions--- can be used to modify or combine base tables in various ways.-data TableExpression- (outer :: FromType)- (commons :: FromType)- (grp :: Grouping)- (schemas :: SchemasType)- (params :: [NullityType])- (from :: FromType)- = TableExpression- { fromClause :: FromClause outer commons schemas params from- -- ^ A table reference that can be a table name, or a derived table such- -- as a subquery, a @JOIN@ construct, or complex combinations of these.- , whereClause :: [Condition outer commons 'Ungrouped schemas params from]- -- ^ optional search coditions, combined with `.&&`. After the processing- -- of the `fromClause` is done, each row of the derived virtual table- -- is checked against the search condition. If the result of the- -- condition is true, the row is kept in the output table,- -- otherwise it is discarded. The search condition typically references- -- at least one column of the table generated in the `fromClause`;- -- this is not required, but otherwise the WHERE clause will- -- be fairly useless.- , groupByClause :: GroupByClause grp from- -- ^ The `groupByClause` is used to group together those rows in a table- -- that have the same values in all the columns listed. The order in which- -- the columns are listed does not matter. The effect is to combine each- -- set of rows having common values into one group row that represents all- -- rows in the group. This is done to eliminate redundancy in the output- -- and/or compute aggregates that apply to these groups.- , havingClause :: HavingClause outer commons grp schemas params from- -- ^ If a table has been grouped using `groupBy`, but only certain groups- -- are of interest, the `havingClause` can be used, much like a- -- `whereClause`, to eliminate groups from the result. Expressions in the- -- `havingClause` can refer both to grouped expressions and to ungrouped- -- expressions (which necessarily involve an aggregate function).- , orderByClause :: [SortExpression outer commons grp schemas params from]- -- ^ The `orderByClause` is for optional sorting. When more than one- -- `SortExpression` is specified, the later (right) values are used to sort- -- rows that are equal according to the earlier (left) values.- , limitClause :: [Word64]- -- ^ The `limitClause` is combined with `min` to give a limit count- -- if nonempty. If a limit count is given, no more than that many rows- -- will be returned (but possibly fewer, if the query itself yields- -- fewer rows).- , offsetClause :: [Word64]- -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count- -- if nonempty. The offset count says to skip that many rows before- -- beginning to return rows. The rows are skipped before the limit count- -- is applied.- } deriving (GHC.Generic)---- | Render a `TableExpression`-instance RenderSQL (TableExpression outer commons grp schemas params from) where- renderSQL- (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat- [ "FROM ", renderSQL frm'- , renderWheres whs'- , renderSQL grps'- , renderSQL hvs'- , renderOrderByClause srts'- , renderLimits lims'- , renderOffsets offs' ]- where- renderWheres = \case- [] -> ""- wh:[] -> " WHERE" <+> renderSQL wh- wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)- renderOrderByClause = \case- [] -> ""- srts -> " ORDER BY"- <+> commaSeparated (renderSQL <$> srts)- renderLimits = \case- [] -> ""- lims -> " LIMIT" <+> fromString (show (minimum lims))- renderOffsets = \case- [] -> ""- offs -> " OFFSET" <+> fromString (show (sum offs))---- | A `from` generates a `TableExpression` from a table reference that can be--- a table name, or a derived table such as a subquery, a JOIN construct,--- or complex combinations of these. A `from` may be transformed by `where_`,--- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator--- to match the left-to-right sequencing of their placement in SQL.-from- :: FromClause outer commons schemas params from -- ^ table reference- -> TableExpression outer commons 'Ungrouped schemas params from-from tab = TableExpression tab [] NoGroups NoHaving [] [] []---- | A `where_` is an endomorphism of `TableExpression`s which adds a--- search condition to the `whereClause`.-where_- :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition- -> TableExpression outer commons grp schemas params from- -> TableExpression outer commons grp schemas params from-where_ wh rels = rels {whereClause = wh : whereClause rels}---- | A `groupBy` is a transformation of `TableExpression`s which switches--- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform--- a "grand total" aggregation query.-groupBy- :: SListI bys- => NP (By from) bys -- ^ grouped columns- -> TableExpression outer commons 'Ungrouped schemas params from- -> TableExpression outer commons ('Grouped bys) schemas params from-groupBy bys rels = TableExpression- { fromClause = fromClause rels- , whereClause = whereClause rels- , groupByClause = Group bys- , havingClause = Having []- , orderByClause = []- , limitClause = limitClause rels- , offsetClause = offsetClause rels- }---- | A `having` is an endomorphism of `TableExpression`s which adds a--- search condition to the `havingClause`.-having- :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition- -> TableExpression outer commons ('Grouped bys) schemas params from- -> TableExpression outer commons ('Grouped bys) schemas params from-having hv rels = rels- { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }--instance OrderBy TableExpression where- orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}---- | A `limit` is an endomorphism of `TableExpression`s which adds to the--- `limitClause`.-limit- :: Word64 -- ^ limit parameter- -> TableExpression outer commons grp schemas params from- -> TableExpression outer commons grp schemas params from-limit lim rels = rels {limitClause = lim : limitClause rels}---- | An `offset` is an endomorphism of `TableExpression`s which adds to the--- `offsetClause`.-offset- :: Word64 -- ^ offset parameter- -> TableExpression outer commons grp schemas params from- -> TableExpression outer commons grp schemas params from-offset off rels = rels {offsetClause = off : offsetClause rels}--{------------------------------------------FROM clauses------------------------------------------}--{- |-A `FromClause` can be a table name, or a derived table such-as a subquery, a @JOIN@ construct, or complex combinations of these.--}-newtype FromClause outer commons schemas params from- = UnsafeFromClause { renderFromClause :: ByteString }- deriving (GHC.Generic,Show,Eq,Ord,NFData)-instance RenderSQL (FromClause outer commons schemas params from) where- renderSQL = renderFromClause---- | A real `table` is a table from the database.-table- :: (Has sch schemas schema, Has tab schema ('Table table))- => Aliased (QualifiedAlias sch) (alias ::: tab)- -> FromClause outer commons schemas params '[alias ::: TableToRow table]-table (tab `As` alias) = UnsafeFromClause $- renderSQL tab <+> "AS" <+> renderSQL alias---- | `subquery` derives a table from a `Query`.-subquery- :: Aliased (Query outer commons schemas params) query- -> FromClause outer commons schemas params '[query]-subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)---- | `view` derives a table from a `View`.-view- :: (Has sch schemas schema, Has vw schema ('View view))- => Aliased (QualifiedAlias sch) (alias ::: vw)- -> FromClause outer commons schemas params '[alias ::: view]-view (vw `As` alias) = UnsafeFromClause $- renderSQL vw <+> "AS" <+> renderSQL alias---- | `common` derives a table from a common table expression.-common- :: Has cte commons common- => Aliased Alias (alias ::: cte)- -> FromClause outer commons schemas params '[alias ::: common]-common (cte `As` alias) = UnsafeFromClause $- renderSQL cte <+> "AS" <+> renderSQL alias--instance Additional (FromClause outer commons schemas params) where- also right left = UnsafeFromClause $- renderSQL left <> ", " <> renderSQL right--{- |-@left & crossJoin right@. For every possible combination of rows from-@left@ and @right@ (i.e., a Cartesian product), the joined table will contain-a row consisting of all columns in @left@ followed by all columns in @right@.-If the tables have @n@ and @m@ rows respectively, the joined table will-have @n * m@ rows.--}-crossJoin- :: FromClause outer commons schemas params right- -- ^ right- -> FromClause outer commons schemas params left- -- ^ left- -> FromClause outer commons schemas params (Join left right)-crossJoin right left = UnsafeFromClause $- renderSQL left <+> "CROSS JOIN" <+> renderSQL right--{- | @left & innerJoin right on@. The joined table is filtered by-the @on@ condition.--}-innerJoin- :: FromClause outer commons schemas params right- -- ^ right- -> Condition outer commons 'Ungrouped schemas params (Join left right)- -- ^ @on@ condition- -> FromClause outer commons schemas params left- -- ^ left- -> FromClause outer commons schemas params (Join left right)-innerJoin right on left = UnsafeFromClause $- renderSQL left <+> "INNER JOIN" <+> renderSQL right- <+> "ON" <+> renderSQL on--{- | @left & leftOuterJoin right on@. First, an inner join is performed.- Then, for each row in @left@ that does not satisfy the @on@ condition with- any row in @right@, a joined row is added with null values in columns of @right@.- Thus, the joined table always has at least one row for each row in @left@.--}-leftOuterJoin- :: FromClause outer commons schemas params right- -- ^ right- -> Condition outer commons 'Ungrouped schemas params (Join left right)- -- ^ @on@ condition- -> FromClause outer commons schemas params left- -- ^ left- -> FromClause outer commons schemas params (Join left (NullifyFrom right))-leftOuterJoin right on left = UnsafeFromClause $- renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right- <+> "ON" <+> renderSQL on--{- | @left & rightOuterJoin right on@. First, an inner join is performed.- Then, for each row in @right@ that does not satisfy the @on@ condition with- any row in @left@, a joined row is added with null values in columns of @left@.- This is the converse of a left join: the result table will always- have a row for each row in @right@.--}-rightOuterJoin- :: FromClause outer commons schemas params right- -- ^ right- -> Condition outer commons 'Ungrouped schemas params (Join left right)- -- ^ @on@ condition- -> FromClause outer commons schemas params left- -- ^ left- -> FromClause outer commons schemas params (Join (NullifyFrom left) right)-rightOuterJoin right on left = UnsafeFromClause $- renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right- <+> "ON" <+> renderSQL on--{- | @left & fullOuterJoin right on@. First, an inner join is performed.- Then, for each row in @left@ that does not satisfy the @on@ condition with- any row in @right@, a joined row is added with null values in columns of @right@.- Also, for each row of @right@ that does not satisfy the join condition- with any row in @left@, a joined row with null values in the columns of @left@- is added.--}-fullOuterJoin- :: FromClause outer commons schemas params right- -- ^ right- -> Condition outer commons 'Ungrouped schemas params (Join left right)- -- ^ @on@ condition- -> FromClause outer commons schemas params left- -- ^ left- -> FromClause outer commons schemas params- (Join (NullifyFrom left) (NullifyFrom right))-fullOuterJoin right on left = UnsafeFromClause $- renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right- <+> "ON" <+> renderSQL on--{------------------------------------------Grouping------------------------------------------}---- | `By`s are used in `groupBy` to reference a list of columns which are then--- used to group together those rows in a table that have the same values--- in all the columns listed. @By \#col@ will reference an unambiguous--- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table--- qualified column @tab.col@.-data By- (from :: FromType)- (by :: (Symbol,Symbol)) where- By1- :: (HasUnique table from columns, Has column columns ty)- => Alias column- -> By from '(table, column)- By2- :: (Has table from columns, Has column columns ty)- => Alias table- -> Alias column- -> By from '(table, column)-deriving instance Show (By from by)-deriving instance Eq (By from by)-deriving instance Ord (By from by)-instance RenderSQL (By from by) where- renderSQL = \case- By1 column -> renderSQL column- By2 rel column -> renderSQL rel <> "." <> renderSQL column--instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))- => IsLabel col (By rels by) where fromLabel = By1 fromLabel-instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])- => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil-instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))- => IsQualified rel col (By rels by) where (!) = By2-instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])- => IsQualified rel col (NP (By rels) bys) where- rel ! col = By2 rel col :* Nil---- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.--- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.--- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be--- done on @NoGroups@ while all output `Expression`s must be aggregated--- in @Group Nil@. In general, all output `Expression`s in the--- complement of @bys@ must be aggregated in @Group bys@.-data GroupByClause grp from where- NoGroups :: GroupByClause 'Ungrouped from- Group- :: SListI bys- => NP (By from) bys- -> GroupByClause ('Grouped bys) from---- | Renders a `GroupByClause`.-instance RenderSQL (GroupByClause grp from) where- renderSQL = \case- NoGroups -> ""- Group Nil -> ""- Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys---- | A `HavingClause` is used to eliminate groups that are not of interest.--- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`--- `TableExpression` must use `Having` whose conditions are combined with--- `.&&`.-data HavingClause outer commons grp schemas params from where- NoHaving :: HavingClause outer commons 'Ungrouped schemas params from- Having- :: [Condition outer commons ('Grouped bys) schemas params from]- -> HavingClause outer commons ('Grouped bys) schemas params from-deriving instance Show (HavingClause outer commons grp schemas params from)-deriving instance Eq (HavingClause outer commons grp schemas params from)-deriving instance Ord (HavingClause outer commons grp schemas params from)---- | Render a `HavingClause`.-instance RenderSQL (HavingClause outer commons grp schemas params from) where- renderSQL = \case- NoHaving -> ""- Having [] -> ""- Having conditions ->- " HAVING" <+> commaSeparated (renderSQL <$> conditions)---- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.-data CommonTableExpression statement- (schemas :: SchemasType)- (params :: [NullityType])- (commons0 :: FromType)- (commons1 :: FromType) where- CommonTableExpression- :: Aliased (statement commons schemas params) (cte ::: common)- -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)-instance- ( KnownSymbol cte- , commons1 ~ (cte ::: common ': commons)- ) => Aliasable cte- (statement commons schemas params common)- (CommonTableExpression statement schemas params commons commons1) where- statement `as` cte = CommonTableExpression (statement `as` cte)-instance- ( KnownSymbol cte- , commons1 ~ (cte ::: common ': commons)- ) => Aliasable cte- (statement commons schemas params common)- (AlignedList (CommonTableExpression statement schemas params) commons commons1) where- statement `as` cte = single (statement `as` cte)--instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL- (CommonTableExpression statement schemas params commons0 commons1) where- renderSQL (CommonTableExpression (statement `As` cte)) =- renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)---- | `with` provides a way to write auxiliary statements for use in a larger query.--- These statements, referred to as `CommonTableExpression`s, can be thought of as--- defining temporary tables that exist just for one query.-class With statement where- with- :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1- -- ^ common table expressions- -> statement commons1 schemas params row- -- ^ larger query- -> statement commons0 schemas params row-instance With (Query outer) where- with Done query = query- with ctes query = UnsafeQuery $- "WITH" <+> renderSQL ctes <+> renderSQL query--{- |->>> import Data.Monoid (Sum (..))->>> import Data.Int (Int64)->>> :{- let- query :: Query_ schema () (Sum Int64)- query = withRecursive- ( values_ ((1 & astype int) `as` #n)- `unionAll`- select_ ((#n + 1) `as` #n)- (from (common #t) & where_ (#n .< 100)) `as` #t )- ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))- in printSQL query-:}-WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"--}-withRecursive- :: Aliased (Query outer (recursive ': commons) schemas params) recursive- -> Query outer (recursive ': commons) schemas params row- -> Query outer commons schemas params row-withRecursive (recursive `As` cte) query = UnsafeQuery $- "WITH RECURSIVE" <+> renderSQL cte- <+> "AS" <+> parenthesized (renderSQL recursive)- <+> renderSQL query
+ src/Squeal/PostgreSQL/Query/From.hs view
@@ -0,0 +1,115 @@+{-|+Module: Squeal.PostgreSQL.Query.From+Description: from clauses+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++from clauses+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.From+ ( -- * From Clause+ FromClause (..)+ , table+ , subquery+ , view+ , common+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+FROM clauses+-----------------------------------------}++{- |+A `FromClause` can be a table name, or a derived table such+as a subquery, a @JOIN@ construct, or complex combinations of these.+-}+newtype FromClause+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (from :: FromType)+ = UnsafeFromClause { renderFromClause :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (FromClause lat with db params from) where+ renderSQL = renderFromClause++-- | A real `table` is a table from the database.+table+ :: (Has sch db schema, Has tab schema ('Table table))+ => Aliased (QualifiedAlias sch) (alias ::: tab) -- ^ (renamable) table alias+ -> FromClause lat with db params '[alias ::: TableToRow table]+table (tab `As` alias) = UnsafeFromClause $+ renderSQL tab <+> "AS" <+> renderSQL alias++{- | `subquery` derives a table from a `Query`.+The subquery may not reference columns provided by preceding `FromClause` items.+Use `Squeal.PostgreSQL.Query.From.Join.JoinLateral`+if the subquery must reference columns provided by preceding `FromClause` items.+-}+subquery+ :: Aliased (Query lat with db params) query+ -- ^ aliased `Query`+ -> FromClause lat with db params '[query]+subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)++-- | `view` derives a table from a `View`.+view+ :: (Has sch db schema, Has vw schema ('View view))+ => Aliased (QualifiedAlias sch) (alias ::: vw) -- ^ (renamable) view alias+ -> FromClause lat with db params '[alias ::: view]+view (vw `As` alias) = UnsafeFromClause $+ renderSQL vw <+> "AS" <+> renderSQL alias++-- | `common` derives a table from a common table expression.+common+ :: Has cte with common+ => Aliased Alias (alias ::: cte) -- ^ (renamable) common table expression alias+ -> FromClause lat with db params '[alias ::: common]+common (cte `As` alias) = UnsafeFromClause $+ renderSQL cte <+> "AS" <+> renderSQL alias++instance Additional (FromClause lat with db params) where+ also right left = UnsafeFromClause $+ renderSQL left <> ", " <> renderSQL right
+ src/Squeal/PostgreSQL/Query/From/Join.hs view
@@ -0,0 +1,295 @@+{-|+Module: Squeal.PostgreSQL.Query.From.Join+Description: Squeal joins+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Squeal joins+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.From.Join+ ( -- * Join+ JoinItem (..)+ , cross, crossJoin, crossJoinLateral+ , inner, innerJoin, innerJoinLateral+ , leftOuter, leftOuterJoin, leftOuterJoinLateral+ , rightOuter, rightOuterJoin, rightOuterJoinLateral+ , fullOuter, fullOuterJoin, fullOuterJoinLateral+ ) where++import Generics.SOP hiding (from)++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Query.From+import Squeal.PostgreSQL.Query.From.Set+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- |+A `JoinItem` is the right hand side of a `cross`,+`inner`, `leftOuter`, `rightOuter`, `fullOuter` join of+`FromClause`s.+-}+data JoinItem+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (left :: FromType)+ (right :: FromType) where+ Join+ :: FromClause lat with db params right+ -- ^ A standard `Squeal.PostgreSQL.Query.Join`.+ -- It is not allowed to reference columns provided+ -- by preceding `FromClause` items.+ -> JoinItem lat with db params left right+ JoinLateral+ :: Aliased (Query (Join lat left) with db params) query+ -- ^ Subqueries can be preceded by `JoinLateral`.+ -- This allows them to reference columns provided+ -- by preceding `FromClause` items.+ -> JoinItem lat with db params left '[query]+ JoinFunction+ :: SetFun db arg set+ -- ^ Set returning functions can be preceded by `JoinFunction`.+ -- This allows them to reference columns provided+ -- by preceding `FromClause` items.+ -> Expression 'Ungrouped lat with db params left arg+ -- ^ argument+ -> JoinItem lat with db params left '[set]+ JoinFunctionN+ :: SListI args+ => SetFunN db args set+ -- ^ Set returning multi-argument functions+ -- can be preceded by `JoinFunctionN`.+ -- This allows them to reference columns provided+ -- by preceding `FromClause` items.+ -> NP (Expression 'Ungrouped lat with db params left) args+ -- ^ arguments+ -> JoinItem lat with db params left '[set]+instance RenderSQL (JoinItem lat with db params left right) where+ renderSQL = \case+ Join tab -> "JOIN" <+> renderSQL tab+ JoinLateral qry -> "JOIN LATERAL" <+>+ renderAliased (parenthesized . renderSQL) qry+ JoinFunction fun x -> "JOIN" <+>+ renderSQL (fun (UnsafeExpression (renderSQL x)))+ JoinFunctionN fun xs -> "JOIN" <+>+ renderSQL (fun (SOP.hmap (UnsafeExpression . renderSQL) xs))++{- |+@left & cross (Join right)@. For every possible combination of rows from+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain+a row consisting of all columns in @left@ followed by all columns in @right@.+If the tables have @n@ and @m@ rows respectively, the joined table will+have @n * m@ rows.+-}+cross+ :: JoinItem lat with db params left right -- ^ right+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left right)+cross item tab = UnsafeFromClause $+ renderSQL tab <+> "CROSS" <+> renderSQL item++{- |+@left & crossJoin right@. For every possible combination of rows from+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain+a row consisting of all columns in @left@ followed by all columns in @right@.+If the tables have @n@ and @m@ rows respectively, the joined table will+have @n * m@ rows.+-}+crossJoin+ :: FromClause lat with db params right -- ^ right+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left right)+crossJoin = cross . Join++{- |+Like `crossJoin` with a `subquery` but allowed to reference columns provided+by preceding `FromClause` items.+-}+crossJoinLateral+ :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left '[query])+crossJoinLateral = cross . JoinLateral++{- | @left & inner (Join right) on@. The joined table is filtered by+the @on@ condition.+-}+inner+ :: JoinItem lat with db params left right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left right)+inner item on tab = UnsafeFromClause $+ renderSQL tab <+> "INNER" <+> renderSQL item <+> "ON" <+> renderSQL on++{- | @left & innerJoin right on@. The joined table is filtered by+the @on@ condition.+-}+innerJoin+ :: FromClause lat with db params right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left right)+innerJoin = inner . Join++{- |+Like `innerJoin` with a `subquery` but allowed to reference columns provided+by preceding `FromClause` items.+-}+innerJoinLateral+ :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery+ -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left '[query])+innerJoinLateral = inner . JoinLateral++{- | @left & leftOuter (Join right) on@. First, an inner join is performed.+Then, for each row in @left@ that does not satisfy the @on@ condition with+any row in @right@, a joined row is added with null values in columns of @right@.+Thus, the joined table always has at least one row for each row in @left@.+-}+leftOuter+ :: JoinItem lat with db params left right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left (NullifyFrom right))+leftOuter item on tab = UnsafeFromClause $+ renderSQL tab <+> "LEFT OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on++{- | @left & leftOuterJoin right on@. First, an inner join is performed.+Then, for each row in @left@ that does not satisfy the @on@ condition with+any row in @right@, a joined row is added with null values in columns of @right@.+Thus, the joined table always has at least one row for each row in @left@.+-}+leftOuterJoin+ :: FromClause lat with db params right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left (NullifyFrom right))+leftOuterJoin = leftOuter . Join++{- |+Like `leftOuterJoin` with a `subquery` but allowed to reference columns provided+by preceding `FromClause` items.+-}+leftOuterJoinLateral+ :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery+ -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join left (NullifyFrom '[query]))+leftOuterJoinLateral = leftOuter . JoinLateral++{- | @left & rightOuter (Join right) on@. First, an inner join is performed.+Then, for each row in @right@ that does not satisfy the @on@ condition with+any row in @left@, a joined row is added with null values in columns of @left@.+This is the converse of a left join: the result table will always+have a row for each row in @right@.+-}+rightOuter+ :: JoinItem lat with db params left right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join (NullifyFrom left) right)+rightOuter item on tab = UnsafeFromClause $+ renderSQL tab <+> "RIGHT OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on++{- | @left & rightOuterJoin right on@. First, an inner join is performed.+Then, for each row in @right@ that does not satisfy the @on@ condition with+any row in @left@, a joined row is added with null values in columns of @left@.+This is the converse of a left join: the result table will always+have a row for each row in @right@.+-}+rightOuterJoin+ :: FromClause lat with db params right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join (NullifyFrom left) right)+rightOuterJoin = rightOuter . Join++{- |+Like `rightOuterJoin` with a `subquery` but allowed to reference columns provided+by preceding `FromClause` items.+-}+rightOuterJoinLateral+ :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery+ -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (Join (NullifyFrom left) '[query])+rightOuterJoinLateral = rightOuter . JoinLateral++{- | @left & fullOuter (Join right) on@. First, an inner join is performed.+Then, for each row in @left@ that does not satisfy the @on@ condition with+any row in @right@, a joined row is added with null values in columns of @right@.+Also, for each row of @right@ that does not satisfy the join condition+with any row in @left@, a joined row with null values in the columns of @left@+is added.+-}+fullOuter+ :: JoinItem lat with db params left right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (NullifyFrom (Join left right))+fullOuter item on tab = UnsafeFromClause $+ renderSQL tab <+> "FULL OUTER" <+> renderSQL item <+> "ON" <+> renderSQL on++{- | @left & fullOuterJoin right on@. First, an inner join is performed.+Then, for each row in @left@ that does not satisfy the @on@ condition with+any row in @right@, a joined row is added with null values in columns of @right@.+Also, for each row of @right@ that does not satisfy the join condition+with any row in @left@, a joined row with null values in the columns of @left@+is added.+-}+fullOuterJoin+ :: FromClause lat with db params right -- ^ right+ -> Condition 'Ungrouped lat with db params (Join left right) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (NullifyFrom (Join left right))+fullOuterJoin = fullOuter . Join++{- |+Like `fullOuterJoin` with a `subquery` but allowed to reference columns provided+by preceding `FromClause` items.+-}+fullOuterJoinLateral+ :: Aliased (Query (Join lat left) with db params) query -- ^ right subquery+ -> Condition 'Ungrouped lat with db params (Join left '[query]) -- ^ @ON@ condition+ -> FromClause lat with db params left -- ^ left+ -> FromClause lat with db params (NullifyFrom (Join left '[query]))+fullOuterJoinLateral = fullOuter . JoinLateral
+ src/Squeal/PostgreSQL/Query/From/Set.hs view
@@ -0,0 +1,205 @@+{-|+Module: Squeal.PostgreSQL.Query.From.Set+Description: set returning functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++set returning functions+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.From.Set+ ( -- * Set Functions+ type (-|->)+ , type (--|->)+ , SetFun+ , SetFunN+ , generateSeries+ , generateSeriesStep+ , generateSeriesTimestamp+ , unsafeSetFunction+ , setFunction+ , unsafeSetFunctionN+ , setFunctionN+ ) where++import Data.ByteString (ByteString)+import Generics.SOP hiding (from)+import GHC.TypeLits++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Query.From+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema++{- |+A @RankNType@ for set returning functions with 1 argument.+-}+type (-|->) arg set = forall db. SetFun db arg set++{- |+A @RankNType@ for set returning functions with multiple argument.+-}+type (--|->) arg set = forall db. SetFunN db arg set+ -- ^ output++{- |+Like `-|->` but depends on the schemas of the database+-}+type SetFun db arg row+ = forall lat with params+ . Expression 'Ungrouped lat with db params '[] arg+ -- ^ input+ -> FromClause lat with db params '[row]+ -- ^ output++{- |+Like `--|->` but depends on the schemas of the database+-}+type SetFunN db args set+ = forall lat with params+ . NP (Expression 'Ungrouped lat with db params '[]) args+ -- ^ input+ -> FromClause lat with db params '[set]+ -- ^ output++-- $setup+-- >>> import Squeal.PostgreSQL++-- | Escape hatch for a set returning function of a single variable+unsafeSetFunction+ :: forall fun ty row. KnownSymbol fun+ => ByteString+ -> ty -|-> (fun ::: row) -- ^ set returning function+unsafeSetFunction fun x = UnsafeFromClause $+ fun <> parenthesized (renderSQL x)++{- | Call a user defined set returning function of a single variable++>>> type Fn = '[ 'Null 'PGbool] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric]+>>> type Schema = '["fn" ::: 'Function Fn]+>>> :{+let+ fn :: SetFun (Public Schema) ('Null 'PGbool) ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric])+ fn = setFunction #fn+in+ printSQL (fn true)+:}+"fn"(TRUE)+-}+setFunction+ :: ( Has sch db schema+ , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )+ => QualifiedAlias sch fun -- ^ function alias+ -> SetFun db ty (fun ::: row)+setFunction fun = unsafeSetFunction (renderSQL fun)++{- | Escape hatch for a multivariable set returning function-}+unsafeSetFunctionN+ :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)+ => ByteString+ -> tys --|-> (fun ::: row) -- ^ set returning function+unsafeSetFunctionN fun xs = UnsafeFromClause $+ fun <> parenthesized (renderCommaSeparated renderSQL xs)++{- | Call a user defined multivariable set returning function++>>> type Fn = '[ 'Null 'PGbool, 'Null 'PGtext] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric]+>>> type Schema = '["fn" ::: 'Function Fn]+>>> :{+let+ fn :: SetFunN (Public Schema)+ '[ 'Null 'PGbool, 'Null 'PGtext]+ ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric])+ fn = setFunctionN #fn+in+ printSQL (fn (true *: "hi"))+:}+"fn"(TRUE, (E'hi' :: text))+-}+setFunctionN+ :: ( Has sch db schema+ , Has fun schema ('Function (tys :=> 'ReturnsTable row))+ , SOP.SListI tys )+ => QualifiedAlias sch fun -- ^ function alias+ -> SetFunN db tys (fun ::: row)+setFunctionN fun = unsafeSetFunctionN (renderSQL fun)++{- | @generateSeries (start :* stop)@++Generate a series of values,+from @start@ to @stop@ with a step size of one++>>> printSQL (generateSeries @'PGint4 (1 *: 10))+generate_series((1 :: int4), (10 :: int4))+-}+generateSeries+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]+ => '[ null ty, null ty] --|->+ ("generate_series" ::: '["generate_series" ::: null ty])+ -- ^ set returning function+generateSeries = unsafeSetFunctionN "generate_series"++{- | @generateSeriesStep (start :* stop *: step)@++Generate a series of values,+from @start@ to @stop@ with a step size of @step@++>>> printSQL (generateSeriesStep @'PGint8 (2 :* 100 *: 2))+generate_series((2 :: int8), (100 :: int8), (2 :: int8))+-}+generateSeriesStep+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]+ => '[null ty, null ty, null ty] --|->+ ("generate_series" ::: '["generate_series" ::: null ty])+ -- ^ set returning function+generateSeriesStep = unsafeSetFunctionN "generate_series"++{- | @generateSeriesTimestamp (start :* stop *: step)@++Generate a series of timestamps,+from @start@ to @stop@ with a step size of @step@++>>> :{+let+ start = now+ stop = now !+ interval_ 10 Years+ step = interval_ 1 Months+in printSQL (generateSeriesTimestamp (start :* stop *: step))+:}+generate_series(now(), (now() + (INTERVAL '10.000 years')), (INTERVAL '1.000 months'))+-}+generateSeriesTimestamp+ :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]+ => '[null ty, null ty, null 'PGinterval] --|->+ ("generate_series" ::: '["generate_series" ::: null ty])+ -- ^ set returning function+generateSeriesTimestamp = unsafeSetFunctionN "generate_series"
+ src/Squeal/PostgreSQL/Query/Select.hs view
@@ -0,0 +1,253 @@+{-|+Module: Squeal.PostgreSQL.Query.Select+Description: select statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++select statements+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.Select+ ( -- ** Select+ select+ , select_+ , selectDistinct+ , selectDistinct_+ , selectDistinctOn+ , selectDistinctOn_+ , Selection (..)+ ) where++import Data.ByteString (ByteString)+import Data.String+import Generics.SOP hiding (from)+import GHC.TypeLits++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Expression.Sort+import Squeal.PostgreSQL.Expression.Window+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Query.Table+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+SELECT queries+-----------------------------------------}++{- | The simplest kinds of `Selection` are `Star` and `DotStar` which+emits all columns that a `TableExpression` produces. A select `List`+is a list of `Expression`s. A `Selection` could be a list of+`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can+be selected with `Also`.+-}+data Selection grp lat with db params from row where+ Star+ :: HasUnique tab from row+ => Selection 'Ungrouped lat with db params from row+ -- ^ `HasUnique` table in the `Squeal.PostgreSQL.Query.From.FromClause`+ DotStar+ :: Has tab from row+ => Alias tab+ -- ^ `Has` table with `Alias`+ -> Selection 'Ungrouped lat with db params from row+ List+ :: SListI row+ => NP (Aliased (Expression grp lat with db params from)) row+ -- ^ `NP` list of `Aliased` `Expression`s+ -> Selection grp lat with db params from row+ Over+ :: SListI row+ => NP (Aliased (WindowFunction grp lat with db params from)) row+ -- ^ `NP` list of `Aliased` `WindowFunction`s+ -> WindowDefinition grp lat with db params from+ -> Selection grp lat with db params from row+ Also+ :: Selection grp lat with db params from right+ -- ^ `Additional` `Selection`+ -> Selection grp lat with db params from left+ -> Selection grp lat with db params from (Join left right)+instance Additional (Selection grp lat with db params from) where+ also = Also+instance (KnownSymbol col, row ~ '[col ::: ty])+ => Aliasable col+ (Expression grp lat with db params from ty)+ (Selection grp lat with db params from row) where+ expr `as` col = List (expr `as` col)+instance (Has tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty])+ => IsQualified tab col+ (Selection 'Ungrouped lat with db params from row1) where+ tab ! col = tab ! col `as` col+instance+ ( Has tab (Join from lat) row0+ , Has col row0 ty+ , row1 ~ '[col ::: ty]+ , GroupedBy tab col bys )+ => IsQualified tab col+ (Selection ('Grouped bys) lat with db params from row1) where+ tab ! col = tab ! col `as` col+instance (HasUnique tab (Join from lat) row0, Has col row0 ty, row1 ~ '[col ::: ty])+ => IsLabel col+ (Selection 'Ungrouped lat with db params from row1) where+ fromLabel = fromLabel @col `as` Alias+instance+ ( HasUnique tab (Join from lat) row0+ , Has col row0 ty+ , row1 ~ '[col ::: ty]+ , GroupedBy tab col bys )+ => IsLabel col+ (Selection ('Grouped bys) lat with db params from row1) where+ fromLabel = fromLabel @col `as` Alias++instance RenderSQL (Selection grp lat with db params from row) where+ renderSQL = \case+ List list -> renderCommaSeparated (renderAliased renderSQL) list+ Star -> "*"+ DotStar tab -> renderSQL tab <> ".*"+ Also right left -> renderSQL left <> ", " <> renderSQL right+ Over winFns winDef ->+ let+ renderOver+ :: Aliased (WindowFunction grp lat with db params from) field+ -> ByteString+ renderOver (winFn `As` col) = renderSQL winFn+ <+> "OVER" <+> parenthesized (renderSQL winDef)+ <+> "AS" <+> renderSQL col+ in+ renderCommaSeparated renderOver winFns++instance IsString+ (Selection grp lat with db params from '["fromOnly" ::: 'NotNull 'PGtext]) where+ fromString str = fromString str `as` Alias++-- | the `TableExpression` in the `select` command constructs an intermediate+-- virtual table by possibly combining tables, views, eliminating rows,+-- grouping, etc. This table is finally passed on to processing by+-- the select list. The `Selection` determines which columns of+-- the intermediate table are actually output.+select+ :: (SListI row, row ~ (x ': xs))+ => Selection grp lat with db params from row+ -- ^ selection+ -> TableExpression grp lat with db params from+ -- ^ intermediate virtual table+ -> Query lat with db params row+select selection tabexpr = UnsafeQuery $+ "SELECT"+ <+> renderSQL selection+ <+> renderSQL tabexpr++-- | Like `select` but takes an `NP` list of `Expression`s instead+-- of a general `Selection`.+select_+ :: (SListI row, row ~ (x ': xs))+ => NP (Aliased (Expression grp lat with db params from)) row+ -- ^ select list+ -> TableExpression grp lat with db params from+ -- ^ intermediate virtual table+ -> Query lat with db params row+select_ = select . List++-- | After the select list has been processed, the result table can+-- be subject to the elimination of duplicate rows using `selectDistinct`.+selectDistinct+ :: (SListI columns, columns ~ (col ': cols))+ => Selection grp lat with db params from columns+ -- ^ selection+ -> TableExpression grp lat with db params from+ -- ^ intermediate virtual table+ -> Query lat with db params columns+selectDistinct selection tabexpr = UnsafeQuery $+ "SELECT DISTINCT"+ <+> renderSQL selection+ <+> renderSQL tabexpr++-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead+-- of a general `Selection`.+selectDistinct_+ :: (SListI columns, columns ~ (col ': cols))+ => NP (Aliased (Expression grp lat with db params from)) columns+ -- ^ select list+ -> TableExpression grp lat with db params from+ -- ^ intermediate virtual table+ -> Query lat with db params columns+selectDistinct_ = selectDistinct . List++{-|+`selectDistinctOn` keeps only the first row of each set of rows where+the given expressions evaluate to equal. The DISTINCT ON expressions are+interpreted using the same rules as for ORDER BY. ORDER BY is used to+ensure that the desired row appears first.++The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).+The ORDER BY clause will normally contain additional expression(s) that+determine the desired precedence of rows within each DISTINCT ON group.++In order to guarantee they match and reduce redundancy, this function+will prepend the The DISTINCT ON expressions to the ORDER BY clause.+-}+selectDistinctOn+ :: (SListI columns, columns ~ (col ': cols))+ => [SortExpression grp lat with db params from]+ -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause+ -> Selection grp lat with db params from columns+ -- ^ selection+ -> TableExpression grp lat with db params from+ -- ^ intermediate virtual table+ -> Query lat with db params columns+selectDistinctOn distincts selection tab = UnsafeQuery $+ "SELECT DISTINCT ON"+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))+ <+> renderSQL selection+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})+ where+ renderDistinctOn = \case+ Asc expression -> renderSQL expression+ Desc expression -> renderSQL expression+ AscNullsFirst expression -> renderSQL expression+ DescNullsFirst expression -> renderSQL expression+ AscNullsLast expression -> renderSQL expression+ DescNullsLast expression -> renderSQL expression++-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead+-- of a general `Selection`.+selectDistinctOn_+ :: (SListI columns, columns ~ (col ': cols))+ => [SortExpression grp lat with db params from]+ -- ^ distinct on and return the first row in ordering+ -> NP (Aliased (Expression grp lat with db params from)) columns+ -- ^ selection+ -> TableExpression grp lat with db params from+ -- ^ intermediate virtual table+ -> Query lat with db params columns+selectDistinctOn_ distincts = selectDistinctOn distincts . List
+ src/Squeal/PostgreSQL/Query/Table.hs view
@@ -0,0 +1,410 @@+{-|+Module: Squeal.PostgreSQL.Query.Table+Description: intermediate table expressions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++intermediate table expressions+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.Table+ ( -- * Table Expression+ TableExpression (..)+ , from+ , where_+ , groupBy+ , having+ , limit+ , offset+ , lockRows+ -- * Grouping+ , By (..)+ , GroupByClause (..)+ , HavingClause (..)+ -- * Row Locks+ , LockingClause (..)+ , LockStrength (..)+ , Waiting (..)+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.String+import Data.Word+import Generics.SOP hiding (from)+import GHC.TypeLits++import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Sort+import Squeal.PostgreSQL.Query.From+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{-----------------------------------------+Table Expressions+-----------------------------------------}++-- | A `TableExpression` computes a table. The table expression contains+-- a `fromClause` that is optionally followed by a `whereClause`,+-- `groupByClause`, `havingClause`, `orderByClause`, `limitClause`+-- `offsetClause` and `lockingClauses`. Trivial table expressions simply refer+-- to a table on disk, a so-called base table, but more complex expressions+-- can be used to modify or combine base tables in various ways.+data TableExpression+ (grp :: Grouping)+ (lat :: FromType)+ (with :: FromType)+ (db :: SchemasType)+ (params :: [NullType])+ (from :: FromType)+ = TableExpression+ { fromClause :: FromClause lat with db params from+ -- ^ A table reference that can be a table name, or a derived table such+ -- as a subquery, a @JOIN@ construct, or complex combinations of these.+ , whereClause :: [Condition 'Ungrouped lat with db params from]+ -- ^ optional search coditions, combined with `.&&`. After the processing+ -- of the `fromClause` is done, each row of the derived virtual table+ -- is checked against the search condition. If the result of the+ -- condition is true, the row is kept in the output table,+ -- otherwise it is discarded. The search condition typically references+ -- at least one column of the table generated in the `fromClause`;+ -- this is not required, but otherwise the WHERE clause will+ -- be fairly useless.+ , groupByClause :: GroupByClause grp from+ -- ^ The `groupByClause` is used to group together those rows in a table+ -- that have the same values in all the columns listed. The order in which+ -- the columns are listed does not matter. The effect is to combine each+ -- set of rows having common values into one group row that represents all+ -- rows in the group. This is done to eliminate redundancy in the output+ -- and/or compute aggregates that apply to these groups.+ , havingClause :: HavingClause grp lat with db params from+ -- ^ If a table has been grouped using `groupBy`, but only certain groups+ -- are of interest, the `havingClause` can be used, much like a+ -- `whereClause`, to eliminate groups from the result. Expressions in the+ -- `havingClause` can refer both to grouped expressions and to ungrouped+ -- expressions (which necessarily involve an aggregate function).+ , orderByClause :: [SortExpression grp lat with db params from]+ -- ^ The `orderByClause` is for optional sorting. When more than one+ -- `SortExpression` is specified, the later (right) values are used to sort+ -- rows that are equal according to the earlier (left) values.+ , limitClause :: [Word64]+ -- ^ The `limitClause` is combined with `min` to give a limit count+ -- if nonempty. If a limit count is given, no more than that many rows+ -- will be returned (but possibly fewer, if the query itself yields+ -- fewer rows).+ , offsetClause :: [Word64]+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count+ -- if nonempty. The offset count says to skip that many rows before+ -- beginning to return rows. The rows are skipped before the limit count+ -- is applied.+ , lockingClauses :: [LockingClause from]+ -- ^ `lockingClauses` can be added to a table expression with `lockRows`.+ } deriving (GHC.Generic)++-- | Render a `TableExpression`+instance RenderSQL (TableExpression grp lat with db params from) where+ renderSQL+ (TableExpression frm' whs' grps' hvs' srts' lims' offs' lks') = mconcat+ [ "FROM ", renderSQL frm'+ , renderWheres whs'+ , renderSQL grps'+ , renderSQL hvs'+ , renderSQL srts'+ , renderLimits lims'+ , renderOffsets offs'+ , renderLocks lks' ]+ where+ renderWheres = \case+ [] -> ""+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)+ renderLimits = \case+ [] -> ""+ lims -> " LIMIT" <+> fromString (show (minimum lims))+ renderOffsets = \case+ [] -> ""+ offs -> " OFFSET" <+> fromString (show (sum offs))+ renderLocks = foldr (\l b -> b <+> renderSQL l) ""++-- | A `from` generates a `TableExpression` from a table reference that can be+-- a table name, or a derived table such as a subquery, a JOIN construct,+-- or complex combinations of these. A `from` may be transformed by `where_`,+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`,+-- using the `Data.Function.&` operator+-- to match the left-to-right sequencing of their placement in SQL.+from+ :: FromClause lat with db params from -- ^ table reference+ -> TableExpression 'Ungrouped lat with db params from+from tab = TableExpression tab [] noGroups NoHaving [] [] [] []++-- | A `where_` is an endomorphism of `TableExpression`s which adds a+-- search condition to the `whereClause`.+where_+ :: Condition 'Ungrouped lat with db params from -- ^ filtering condition+ -> TableExpression grp lat with db params from+ -> TableExpression grp lat with db params from+where_ wh rels = rels {whereClause = wh : whereClause rels}++-- | A `groupBy` is a transformation of `TableExpression`s which switches+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform+-- a "grand total" aggregation query.+groupBy+ :: SListI bys+ => NP (By from) bys -- ^ grouped columns+ -> TableExpression 'Ungrouped lat with db params from+ -> TableExpression ('Grouped bys) lat with db params from+groupBy bys rels = TableExpression+ { fromClause = fromClause rels+ , whereClause = whereClause rels+ , groupByClause = group bys+ , havingClause = Having []+ , orderByClause = []+ , limitClause = limitClause rels+ , offsetClause = offsetClause rels+ , lockingClauses = lockingClauses rels+ }++-- | A `having` is an endomorphism of `TableExpression`s which adds a+-- search condition to the `havingClause`.+having+ :: Condition ('Grouped bys) lat with db params from -- ^ having condition+ -> TableExpression ('Grouped bys) lat with db params from+ -> TableExpression ('Grouped bys) lat with db params from+having hv rels = rels+ { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }++instance OrderBy (TableExpression grp) grp where+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}++-- | A `limit` is an endomorphism of `TableExpression`s which adds to the+-- `limitClause`.+limit+ :: Word64 -- ^ limit parameter+ -> TableExpression grp lat with db params from+ -> TableExpression grp lat with db params from+limit lim rels = rels {limitClause = lim : limitClause rels}++-- | An `offset` is an endomorphism of `TableExpression`s which adds to the+-- `offsetClause`.+offset+ :: Word64 -- ^ offset parameter+ -> TableExpression grp lat with db params from+ -> TableExpression grp lat with db params from+offset off rels = rels {offsetClause = off : offsetClause rels}++{- | Add a `LockingClause` to a `TableExpression`.+Multiple `LockingClause`s can be written if it is necessary+to specify different locking behavior for different tables.+If the same table is mentioned (or implicitly affected)+by more than one locking clause, then it is processed+as if it was only specified by the strongest one.+Similarly, a table is processed as `NoWait` if that is specified+in any of the clauses affecting it. Otherwise, it is processed+as `SkipLocked` if that is specified in any of the clauses affecting it.+Further, a `LockingClause` cannot be added to a grouped table expression.+-}+lockRows+ :: LockingClause from -- ^ row-level lock+ -> TableExpression 'Ungrouped lat with db params from+ -> TableExpression 'Ungrouped lat with db params from+lockRows lck tab = tab {lockingClauses = lck : lockingClauses tab}++{-----------------------------------------+Grouping+-----------------------------------------}++-- | `By`s are used in `groupBy` to reference a list of columns which are then+-- used to group together those rows in a table that have the same values+-- in all the columns listed. @By \#col@ will reference an unambiguous+-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table+-- qualified column @tab.col@.+data By+ (from :: FromType)+ (by :: (Symbol,Symbol)) where+ By1+ :: (HasUnique table from columns, Has column columns ty)+ => Alias column+ -> By from '(table, column)+ By2+ :: (Has table from columns, Has column columns ty)+ => Alias table+ -> Alias column+ -> By from '(table, column)+deriving instance Show (By from by)+deriving instance Eq (By from by)+deriving instance Ord (By from by)+instance RenderSQL (By from by) where+ renderSQL = \case+ By1 column -> renderSQL column+ By2 rel column -> renderSQL rel <> "." <> renderSQL column++instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))+ => IsLabel col (By rels by) where fromLabel = By1 fromLabel+instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])+ => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil+instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))+ => IsQualified rel col (By rels by) where (!) = By2+instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])+ => IsQualified rel col (NP (By rels) bys) where+ rel ! col = By2 rel col :* Nil++-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.+newtype GroupByClause grp from = UnsafeGroupByClause+ { renderGroupByClause :: ByteString }+ deriving stock (GHC.Generic,Show,Eq,Ord)+ deriving newtype (NFData)+instance RenderSQL (GroupByClause grp from) where+ renderSQL = renderGroupByClause+noGroups :: GroupByClause 'Ungrouped from+noGroups = UnsafeGroupByClause ""+group+ :: SListI bys+ => NP (By from) bys+ -> GroupByClause ('Grouped bys) from+group bys = UnsafeGroupByClause $ case bys of+ Nil -> ""+ _ -> " GROUP BY" <+> renderCommaSeparated renderSQL bys++-- | A `HavingClause` is used to eliminate groups that are not of interest.+-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`+-- `TableExpression` must use `Having` whose conditions are combined with+-- `.&&`.+data HavingClause grp lat with db params from where+ NoHaving :: HavingClause 'Ungrouped lat with db params from+ Having+ :: [Condition ('Grouped bys) lat with db params from]+ -> HavingClause ('Grouped bys) lat with db params from+deriving instance Show (HavingClause grp lat with db params from)+deriving instance Eq (HavingClause grp lat with db params from)+deriving instance Ord (HavingClause grp lat with db params from)++-- | Render a `HavingClause`.+instance RenderSQL (HavingClause grp lat with db params from) where+ renderSQL = \case+ NoHaving -> ""+ Having [] -> ""+ Having conditions ->+ " HAVING" <+> commaSeparated (renderSQL <$> conditions)++{- |+If specific tables are named in a locking clause,+then only rows coming from those tables are locked;+any other tables used in the `Squeal.PostgreSQL.Query.Select.select` are simply read as usual.+A locking clause with a `Nil` table list affects all tables used in the statement.+If a locking clause is applied to a `view` or `subquery`,+it affects all tables used in the `view` or `subquery`.+However, these clauses do not apply to `Squeal.PostgreSQL.Query.With.with` queries referenced by the primary query.+If you want row locking to occur within a `Squeal.PostgreSQL.Query.With.with` query,+specify a `LockingClause` within the `Squeal.PostgreSQL.Query.With.with` query.+-}+data LockingClause from where+ For+ :: HasAll tabs from tables+ => LockStrength -- ^ lock strength+ -> NP Alias tabs -- ^ table list+ -> Waiting -- ^ wait or not+ -> LockingClause from+instance RenderSQL (LockingClause from) where+ renderSQL (For str tabs wt) =+ "FOR" <+> renderSQL str+ <> case tabs of+ Nil -> ""+ _ -> " OF" <+> renderSQL tabs+ <> renderSQL wt++{- |+Row-level locks, which are listed as below with the contexts+in which they are used automatically by PostgreSQL.+Note that a transaction can hold conflicting locks on the same row,+even in different subtransactions; but other than that,+two transactions can never hold conflicting locks on the same row.+Row-level locks do not affect data querying;+they block only writers and lockers to the same row.+Row-level locks are released at transaction end or during savepoint rollback.+-}+data LockStrength+ = Update+ {- ^ `For` `Update` causes the rows retrieved by the `Squeal.PostgreSQL.Query.Select.select` statement+ to be locked as though for update. This prevents them from being locked,+ modified or deleted by other transactions until the current transaction ends.+ That is, other transactions that attempt `Squeal.PostgreSQL.Manipulation.Update.update`, `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`,+ `Squeal.PostgreSQL.Query.Select.select` `For` `Update`, `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`,+ `Squeal.PostgreSQL.Query.Select.select` `For` `Share` or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` of these rows will be blocked+ until the current transaction ends; conversely, `Squeal.PostgreSQL.Query.Select.select` `For` `Update` will wait+ for a concurrent transaction that has run any of those commands on the same row,+ and will then lock and return the updated row (or no row, if the row was deleted).+ Within a `Squeal.PostgreSQL.Session.Transaction.RepeatableRead` or `Squeal.PostgreSQL.Session.Transaction.Serializable` transaction, however, an error will be+ thrown if a row to be locked has changed since the transaction started.++ The `For` `Update` lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` a row,+ and also by an `Update` that modifies the values on certain columns.+ Currently, the set of columns considered for the `Squeal.PostgreSQL.Manipulation.Update.update` case are those+ that have a unique index on them that can be used in a foreign key+ (so partial indexes and expressional indexes are not considered),+ but this may change in the future.-}+ | NoKeyUpdate+ {- | Behaves similarly to `For` `Update`, except that the lock acquired is weaker:+ this lock will not block `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare` commands that attempt to acquire+ a lock on the same rows. This lock mode is also acquired by any `Squeal.PostgreSQL.Manipulation.Update.update`+ that does not acquire a `For` `Update` lock.-}+ | Share+ {- | Behaves similarly to `For` `Share`, except that the lock is weaker:+ `Squeal.PostgreSQL.Query.Select.select` `For` `Update` is blocked, but not `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`.+ A key-shared lock blocks other transactions from performing+ `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom` or any `Squeal.PostgreSQL.Manipulation.Update.update` that changes the key values,+ but not other `Update`, and neither does it prevent `Squeal.PostgreSQL.Query.Select.select` `For` `NoKeyUpdate`,+ `Squeal.PostgreSQL.Query.Select.select` `For` `Share`, or `Squeal.PostgreSQL.Query.Select.select` `For` `KeyShare`.-}+ | KeyShare+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance RenderSQL LockStrength where+ renderSQL = \case+ Update -> "UPDATE"+ NoKeyUpdate -> "NO KEY UPDATE"+ Share -> "SHARE"+ KeyShare -> "KEY SHARE"++-- | To prevent the operation from `Waiting` for other transactions to commit,+-- use either the `NoWait` or `SkipLocked` option.+data Waiting+ = Wait+ -- ^ wait for other transactions to commit+ | NoWait+ -- ^ reports an error, rather than waiting+ | SkipLocked+ -- ^ any selected rows that cannot be immediately locked are skipped+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance RenderSQL Waiting where+ renderSQL = \case+ Wait -> ""+ NoWait -> " NOWAIT"+ SkipLocked -> " SKIP LOCKED"
+ src/Squeal/PostgreSQL/Query/Values.hs view
@@ -0,0 +1,89 @@+{-|+Module: Squeal.PostgreSQL.Query.Values+Description: values statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++values statements+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.Values+ ( -- ** Values+ values+ , values_+ ) where++import Data.ByteString (ByteString)+import Generics.SOP hiding (from)++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Expression+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Render++-- $setup+-- >>> import Squeal.PostgreSQL++-- | `values` computes a row value or set of row values+-- specified by value expressions. It is most commonly used+-- to generate a “constant table” within a larger command,+-- but it can be used on its own.+--+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query lat with db '[] Row+-- >>> printSQL query+-- SELECT * FROM (VALUES ((1 :: int4), (E'one' :: text))) AS t ("a", "b")+values+ :: SListI cols+ => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols+ -> [NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols]+ -- ^ When more than one row is specified, all the rows must+ -- must have the same number of elements+ -> Query lat with db params cols+values rw rws = UnsafeQuery $ "SELECT * FROM"+ <+> parenthesized (+ "VALUES"+ <+> commaSeparated+ ( parenthesized+ . renderCommaSeparated renderValuePart <$> rw:rws )+ ) <+> "AS t"+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)+ where+ renderAliasPart, renderValuePart+ :: Aliased (Expression 'Ungrouped lat with db params '[] ) ty -> ByteString+ renderAliasPart (_ `As` name) = renderSQL name+ renderValuePart (value `As` _) = renderSQL value++-- | `values_` computes a row value or set of row values+-- specified by value expressions.+values_+ :: SListI cols+ => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols+ -- ^ one row of values+ -> Query lat with db params cols+values_ rw = values rw []
+ src/Squeal/PostgreSQL/Query/With.hs view
@@ -0,0 +1,246 @@+{-|+Module: Squeal.PostgreSQL.Query.With+Description: with statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++with statements+-}++{-# LANGUAGE+ ConstraintKinds+ , DeriveGeneric+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , QuantifiedConstraints+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , RankNTypes+ , UndecidableInstances+ #-}++module Squeal.PostgreSQL.Query.With+ ( -- ** With+ With (..)+ , CommonTableExpression (..)+ , withRecursive+ , Materialization (..)+ , materialized+ , notMaterialized+ ) where++import Data.Quiver.Functor+import GHC.TypeLits++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++{- | `with` provides a way to write auxiliary statements for use in a larger query.+These statements, referred to as `CommonTableExpression`s, can be thought of as+defining temporary tables that exist just for one query.++`with` can be used for a `Query`. Multiple `CommonTableExpression`s can be+chained together with the `Path` constructor `:>>`, and each `CommonTableExpression`+is constructed via overloaded `as`.++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = with (+ select Star (from (table #tab)) `as` #cte1 :>>+ select Star (from (common #cte1)) `as` #cte2+ ) (select Star (from (common #cte2)))+in printSQL qry+:}+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++You can use data-modifying statements in `with`. This allows you to perform several+different operations in the same query. An example is:++>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]+>>> :{+let+ manp :: Manipulation with (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]+ manp = with+ (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)+ (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))+in printSQL manp+:}+WITH "del" AS (DELETE FROM "products" AS "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" AS "products_deleted" SELECT * FROM "del" AS "del"+-}+class With statement where+ with+ :: Path (CommonTableExpression statement db params) with0 with1+ -- ^ common table expressions+ -> statement with1 db params row+ -- ^ larger query+ -> statement with0 db params row+instance With (Query lat) where+ with Done query = query+ with ctes query = UnsafeQuery $+ "WITH" <+> commaSeparated (qtoList renderSQL ctes) <+> renderSQL query++{- | A `withRecursive` `Query` can refer to its own output.+A very simple example is this query to sum the integers from 1 through 100:++>>> import Data.Monoid (Sum (..))+>>> import Data.Int (Int64)+>>> :{+ let+ sum100 :: Statement db () (Sum Int64)+ sum100 = query $+ withRecursive+ ( values_ ((1 & astype int) `as` #n)+ `unionAll`+ select_ ((#n + 1) `as` #n)+ (from (common #t) & where_ (#n .< 100)) `as` #t )+ ( select_+ (fromNull 0 (sum_ (All #n)) `as` #getSum)+ (from (common #t) & groupBy Nil) )+ in printSQL sum100+:}+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (((1 :: int4) :: int))) AS t ("n")) UNION ALL (SELECT ("n" + (1 :: int4)) AS "n" FROM "t" AS "t" WHERE ("n" < (100 :: int4)))) SELECT COALESCE(sum(ALL "n"), (0 :: int8)) AS "getSum" FROM "t" AS "t"++The general form of a recursive WITH query is always a non-recursive term,+then `union` (or `unionAll`), then a recursive term, where+only the recursive term can contain a reference to the query's own output.+-}+withRecursive+ :: Aliased (Query lat (recursive ': with) db params) recursive+ -- ^ recursive query+ -> Query lat (recursive ': with) db params row+ -- ^ larger query+ -> Query lat with db params row+withRecursive (recursive `As` cte) query = UnsafeQuery $+ "WITH RECURSIVE" <+> renderSQL cte+ <+> "AS" <+> parenthesized (renderSQL recursive)+ <+> renderSQL query++-- | Whether the contents of the WITH clause are materialized.+-- If a WITH query is non-recursive and side-effect-free (that is, it is a SELECT containing no volatile functions) then it can be folded into the parent query, allowing joint optimization of the two query levels.+--+-- Note: Use of `Materialized` or `NotMaterialized` requires PostgreSQL version 12 or higher. For earlier versions, use `DefaultMaterialization` which in those earlier versions of PostgreSQL behaves as `Materialized`. PostgreSQL 12 both changes the default behavior as well as adds options for customizing the materialization behavior.+data Materialization =+ DefaultMaterialization -- ^ By default, folding happens if the parent query references the WITH query just once, but not if it references the WITH query more than once. Note: this is the behavior in PostgreSQL 12+. In PostgreSQL 11 and earlier, all CTEs are materialized.+ | Materialized -- ^ You can override that decision by specifying MATERIALIZED to force separate calculation of the WITH query. Requires PostgreSQL 12+.+ | NotMaterialized -- ^ or by specifying NOT MATERIALIZED to force it to be merged into the parent query. Requires PostgreSQL 12+.+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)+instance SOP.Generic Materialization+instance SOP.HasDatatypeInfo Materialization+instance RenderSQL Materialization where+ renderSQL = \case+ DefaultMaterialization -> ""+ Materialized -> "MATERIALIZED"+ NotMaterialized -> "NOT MATERIALIZED"++-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.+data CommonTableExpression statement+ (db :: SchemasType)+ (params :: [NullType])+ (with0 :: FromType)+ (with1 :: FromType) where+ CommonTableExpression+ :: Aliased (statement with db params) (cte ::: common)+ -- ^ aliased statement+ -> Materialization+ -- ^ materialization of the CTE output+ -> CommonTableExpression statement db params with (cte ::: common ': with)+instance+ ( KnownSymbol cte+ , with1 ~ (cte ::: common ': with)+ ) => Aliasable cte+ (statement with db params common)+ (CommonTableExpression statement db params with with1) where+ statement `as` cte = CommonTableExpression (statement `as` cte) DefaultMaterialization+instance+ ( KnownSymbol cte+ , with1 ~ (cte ::: common ': with)+ ) => Aliasable cte+ (statement with db params common)+ (Path (CommonTableExpression statement db params) with with1) where+ statement `as` cte = qsingle (statement `as` cte)++instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL+ (CommonTableExpression statement db params with0 with1) where+ renderSQL (CommonTableExpression (statement `As` cte) materialization) =+ renderSQL cte+ <+> "AS"+ <+> renderSQL materialization+ <> case materialization of+ DefaultMaterialization -> ""+ _ -> " "+ <> parenthesized (renderSQL statement)++{- | Force separate calculation of the WITH query.++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = with (+ materialized (select Star (from (table #tab)) `as` #cte1) :>>+ select Star (from (common #cte1)) `as` #cte2+ ) (select Star (from (common #cte2)))+in printSQL qry+:}+WITH "cte1" AS MATERIALIZED (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done`.++Requires PostgreSQL 12 or higher.+-}+materialized+ :: Aliased (statement with db params) (cte ::: common) -- ^ CTE+ -> CommonTableExpression statement db params with (cte ::: common ': with)+materialized stmt = CommonTableExpression stmt Materialized++{- | Force the WITH query to be merged into the parent query.++>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> :{+let+ qry :: Query lat with (Public Schema) params '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]+ qry = with (+ select Star (from (table #tab)) `as` #cte1 :>>+ notMaterialized (select Star (from (common #cte1)) `as` #cte2) :>>+ Done+ ) (select Star (from (common #cte2)))+in printSQL qry+:}+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS NOT MATERIALIZED (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"++Note: if the last CTE has `materialized` or `notMaterialized` you must add `:>> Done` to finish the `Path`.++Requires PostgreSQL 12 or higher.+-}+notMaterialized+ :: Aliased (statement with db params) (cte ::: common) -- ^ CTE+ -> CommonTableExpression statement db params with (cte ::: common ': with)+notMaterialized stmt = CommonTableExpression stmt NotMaterialized
src/Squeal/PostgreSQL/Render.hs view
@@ -1,11 +1,11 @@ {-| Module: Squeal.PostgreSQL.Render-Description: Rendering helper functions-Copyright: (c) Eitan Chatav, 2017+Description: render functions+Copyright: (c) Eitan Chatav, 2019 Maintainer: eitan@morphism.tech Stability: experimental -Rendering helper functions.+render functions -} {-# LANGUAGE@@ -33,6 +33,8 @@ , doubleQuoted , singleQuotedText , singleQuotedUtf8+ , escapeQuotedString+ , escapeQuotedText , renderCommaSeparated , renderCommaSeparatedConstraint , renderCommaSeparatedMaybe@@ -43,7 +45,6 @@ import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString) import Data.Maybe (catMaybes)-import Data.Monoid ((<>)) import Data.Text (Text) import Generics.SOP import GHC.Exts@@ -84,6 +85,15 @@ singleQuotedUtf8 :: ByteString -> ByteString singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8 +-- | Escape quote a string.+escapeQuotedString :: String -> ByteString+escapeQuotedString x = "E\'" <> Text.encodeUtf8 (fromString (escape =<< x)) <> "\'"++-- | Escape quote a string.+escapeQuotedText :: Text -> ByteString+escapeQuotedText x =+ "E\'" <> Text.encodeUtf8 (Text.concatMap (fromString . escape) x) <> "\'"+ -- | Comma separate the renderings of a heterogeneous list. renderCommaSeparated :: SListI xs@@ -134,7 +144,7 @@ -- | `escape` a character to prevent injection escape :: Char -> String escape = \case- '\NUL' -> "\\0"+ '\NUL' -> "" '\'' -> "''" '"' -> "\\\"" '\b' -> "\\b"
− src/Squeal/PostgreSQL/Schema.hs
@@ -1,449 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Schema-Description: Embedding of PostgreSQL type and alias system-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,-tables, schema, constraints, aliases, enumerated labels, and groupings.-It also defines useful type families to operate on these. Finally,-it defines an embedding of Haskell types into Postgres types.--}-{-# LANGUAGE- AllowAmbiguousTypes- , ConstraintKinds- , DeriveAnyClass- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , LambdaCase- , OverloadedStrings- , QuantifiedConstraints- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TypeApplications- , TypeFamilyDependencies- , TypeInType- , TypeOperators- , UndecidableInstances- , UndecidableSuperClasses-#-}--module Squeal.PostgreSQL.Schema- ( -- * Postgres Types- PGType (..)- , NullityType (..)- , RowType- , FromType- -- * Schema Types- , ColumnType- , ColumnsType- , TableType- , SchemumType (..)- , SchemaType- , SchemasType- , Public- -- * Constraints- , (:=>)- , ColumnConstraint (..)- , TableConstraint (..)- , TableConstraints- , Uniquely- -- * Enumerated Labels- , IsPGlabel (..)- , PGlabel (..)- -- * Data Definitions- , Create- , Drop- , Alter- , Rename- , ConstraintInvolves- , DropIfConstraintsInvolve- , IsNotElem- , AllUnique- -- * Type Classifications- , PGNum- , PGIntegral- , PGFloating- , PGTypeOf- , PGJsonType- , PGJsonKey- , SamePGType- , AllNotNull- , NotAllNull- -- * Nullifications- , NullifyType- , NullifyRow- , NullifyFrom- -- * Table Conversions- , TableToColumns- , ColumnsToRow- , TableToRow- ) where--import Control.Category-import Data.Kind-import Data.Monoid hiding (All)-import Data.Type.Bool-import Generics.SOP-import GHC.TypeLits-import Prelude hiding (id, (.))--import Squeal.PostgreSQL.Alias-import Squeal.PostgreSQL.List-import Squeal.PostgreSQL.Render---- $setup--- >>> import Squeal.PostgreSQL---- | `PGType` is the promoted datakind of PostgreSQL types.------ >>> :kind 'PGbool--- 'PGbool :: PGType-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)- | PGmoney -- ^ currency amount- | 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- | PGvararray NullityType -- ^ variable length array- | PGfixarray [Nat] NullityType -- ^ fixed length array- | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.- | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.- | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.- | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for- | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types---- | `NullityType` encodes the potential presence or definite absence of a--- @NULL@ allowing operations which are sensitive to such to be well typed.------ >>> :kind 'Null 'PGint4--- 'Null 'PGint4 :: NullityType--- >>> :kind 'NotNull ('PGvarchar 50)--- 'NotNull ('PGvarchar 50) :: NullityType-data NullityType- = Null PGType -- ^ @NULL@ may be present- | NotNull PGType -- ^ @NULL@ is absent---- | The constraint operator, `:=>` is a type level pair--- between a "constraint" and some type, for use in pairing--- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType`--- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.-type (:=>) constraint ty = '(constraint,ty)-infixr 7 :=>---- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.--- A column can be assigned a default value.--- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also--- request explicitly that a column be set to its default value,--- without having to know what that value is.-data ColumnConstraint- = Def -- ^ @DEFAULT@ is available for inserts and updates- | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates---- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the--- base `PGType` for a column.------ >>> :set -XTypeFamilies -XTypeInType--- >>> import GHC.TypeLits--- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4--- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext-type ColumnType = (ColumnConstraint,NullityType)---- | `ColumnsType` is a row of `ColumnType`s.------ >>> :{--- type family UsersColumns :: ColumnsType where--- UsersColumns =--- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext--- , "id" ::: 'Def :=> 'NotNull 'PGint4--- ]--- :}-type ColumnsType = [(Symbol,ColumnType)]---- | `TableConstraint` encodes various forms of data constraints--- of columns in a table.--- `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.-data TableConstraint- = Check [Symbol]- | Unique [Symbol]- | PrimaryKey [Symbol]- | ForeignKey [Symbol] Symbol [Symbol]--{- | A `TableConstraints` is a row of `TableConstraint`s.-->>> :{-type family UsersConstraints :: TableConstraints where- UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]-:}--}-type TableConstraints = [(Symbol,TableConstraint)]---- | A `ForeignKey` must reference columns that either are--- a `PrimaryKey` or form a `Unique` constraint.-type family Uniquely- (key :: [Symbol])- (constraints :: TableConstraints) :: Constraint where- Uniquely key (uq ::: 'Unique key ': constraints) = ()- Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()- Uniquely key (_ ': constraints) = Uniquely key constraints---- | `TableType` encodes a row of constraints on a table as well as the types--- of its columns.------ >>> :{--- type family UsersTable :: TableType where--- UsersTable =--- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>--- '[ "id" ::: 'Def :=> 'NotNull 'PGint4--- , "name" ::: 'NoDef :=> 'NotNull 'PGtext--- ]--- :}-type TableType = (TableConstraints,ColumnsType)--{- | A `RowType` is a row of `NullityType`. They correspond to Haskell-record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.-->>> :{-type family PersonRow :: RowType where- PersonRow =- '[ "name" ::: 'NotNull 'PGtext- , "age" ::: 'NotNull 'PGint4- , "dateOfBirth" ::: 'Null 'PGdate- ]-:}--}-type RowType = [(Symbol,NullityType)]--{- | `FromType` is a row of `RowType`s. It can be thought of as-a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s-and `Squeal.PostgreSQL.Query.TableExpression`s.--}-type FromType = [(Symbol,RowType)]---- | `ColumnsToRow` removes column constraints.-type family ColumnsToRow (columns :: ColumnsType) :: RowType where- ColumnsToRow '[] = '[]- ColumnsToRow (column ::: constraint :=> ty ': columns) =- column ::: ty ': ColumnsToRow columns---- | `TableToColumns` removes table constraints.-type family TableToColumns (table :: TableType) :: ColumnsType where- TableToColumns (constraints :=> columns) = columns---- | Convert a table to a row type.-type family TableToRow (table :: TableType) :: RowType where- TableToRow tab = ColumnsToRow (TableToColumns tab)---- | Numeric Postgres types.-type PGNum =- '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]---- | Floating Postgres types.-type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]---- | Integral Postgres types.-type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]---- | `PGTypeOf` forgets about @NULL@ and any column constraints.-type family PGTypeOf (ty :: NullityType) :: PGType where- PGTypeOf (nullity pg) = pg---- | Equality constraint on the underlying `PGType` of two columns.-class SamePGType- (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where-instance ty0 ~ ty1 => SamePGType- (alias0 ::: def0 :=> nullity0 ty0)- (alias1 ::: def1 :=> nullity1 ty1)---- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.-type family AllNotNull (columns :: ColumnsType) :: Constraint where- AllNotNull '[] = ()- AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns---- | `NotAllNull` is a constraint that proves a `ColumnsType` has some--- @NOT NULL@.-type family NotAllNull (columns :: ColumnsType) :: Constraint where- NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()- NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns---- | `NullifyType` is an idempotent that nullifies a `NullityType`.-type family NullifyType (ty :: NullityType) :: NullityType where- NullifyType ('Null ty) = 'Null ty- NullifyType ('NotNull ty) = 'Null ty---- | `NullifyRow` is an idempotent that nullifies a `RowType`.-type family NullifyRow (columns :: RowType) :: RowType where- NullifyRow '[] = '[]- NullifyRow (column ::: ty ': columns) =- column ::: NullifyType ty ': NullifyRow columns---- | `NullifyFrom` is an idempotent that nullifies a `FromType`--- used to nullify the left or right hand side of an outer join--- in a `Squeal.PostgreSQL.Query.FromClause`.-type family NullifyFrom (tables :: FromType) :: FromType where- NullifyFrom '[] = '[]- NullifyFrom (table ::: columns ': tables) =- table ::: NullifyRow columns ': NullifyFrom tables---- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in--- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@--- `Squeal.PostgreSQL.Definition.addColumn`.-type family Create alias x xs where- Create alias x '[] = '[alias ::: x]- Create alias x (alias ::: y ': xs) = TypeError- ('Text "Create: alias "- ':<>: 'ShowType alias- ':<>: 'Text "already in use")- 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 x xs@ 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 x xs where- Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs- Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs---- | @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---- | Check if a `TableConstraint` involves a column-type family ConstraintInvolves column constraint where- ConstraintInvolves column ('Check columns) = column `Elem` columns- ConstraintInvolves column ('Unique columns) = column `Elem` columns- ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns- ConstraintInvolves column ('ForeignKey columns tab refcolumns)- = column `Elem` columns---- | Drop all `TableConstraint`s that involve a column-type family DropIfConstraintsInvolve column constraints where- DropIfConstraintsInvolve column '[] = '[]- DropIfConstraintsInvolve column (alias ::: constraint ': constraints)- = If (ConstraintInvolves column constraint)- (DropIfConstraintsInvolve column constraints)- (alias ::: constraint ': DropIfConstraintsInvolve column constraints)---- | A `SchemumType` is a user-defined type, either a `Table`,--- `View` or `Typedef`.-data SchemumType- = Table TableType- | View RowType- | Typedef PGType--{- | The schema of a database consists of a list of aliased,-user-defined `SchemumType`s.-->>> :{-type family Schema :: SchemaType where- Schema =- '[ "users" ::: 'Table (- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- ])- , "emails" ::: 'Table (- '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4- , "email" ::: 'NoDef :=> 'Null 'PGtext- ])- ]-:}--}-type SchemaType = [(Symbol,SchemumType)]--{- |-A database contains one or more named schemas, which in turn contain tables.-The same object name can be used in different schemas without conflict;-for example, both schema1 and myschema can contain tables named mytable.-Unlike databases, schemas are not rigidly separated:-a user can access objects in any of the schemas in the database they are connected to,-if they have privileges to do so.--There are several reasons why one might want to use schemas:-- * To allow many users to use one database without interfering with each other.- * To organize database objects into logical groups to make them more manageable.- * Third-party applications can be put into separate schemas- so they do not collide with the names of other objects.--}-type SchemasType = [(Symbol,SchemaType)]---- | A type family to use for a single schema database.-type family Public (schema :: SchemaType) :: SchemasType- where Public schema = '["public" ::: schema]---- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas--- the overloaded label, `fromLabel` is used for column references,--- `label`s are used for enum terms. A `label` is called with--- type application like `label @"beef"`.-class IsPGlabel (label :: Symbol) expr where label :: expr-instance label ~ label1- => IsPGlabel label (PGlabel label1) where label = PGlabel-instance labels ~ '[label]- => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil--- | A `PGlabel` unit type with an `IsPGlabel` instance-data PGlabel (label :: Symbol) = PGlabel-instance KnownSymbol label => RenderSQL (PGlabel label) where- renderSQL _ = "\'" <> renderSymbol @label <> "\'"-instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where- renderSQL- = commaSeparated- . hcollapse- . hcmap (Proxy @KnownSymbol) (K . renderSQL)---- | Is a type a valid JSON key?-type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]---- | Is a type a valid JSON type?-type PGJsonType = '[ 'PGjson, 'PGjsonb ]---- | Utility class for `AllUnique` to provide nicer error messages.-class IsNotElem x isElem where-instance IsNotElem x 'False where-instance (TypeError ( 'Text "Cannot assign to "- ':<>: 'ShowType alias- ':<>: 'Text " more than once"))- => IsNotElem '(alias, a) 'True where---- | No elem of @xs@ appears more than once, in the context of assignment.-class AllUnique (xs :: [(Symbol, a)]) where-instance AllUnique '[] where-instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
+ src/Squeal/PostgreSQL/Session.hs view
@@ -0,0 +1,333 @@+{-|+Module: Squeal.PostgreSQL.Session+Description: sessions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Using Squeal in your application will come down to defining+the @DB :: @`SchemasType` of your database and including @PQ DB DB@ in your+application's monad transformer stack, giving it an instance of `MonadPQ` @DB@.+-}++{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# LANGUAGE+ DefaultSignatures+ , FunctionalDependencies+ , FlexibleContexts+ , FlexibleInstances+ , InstanceSigs+ , OverloadedStrings+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Session+ ( PQ (PQ, unPQ)+ , runPQ+ , execPQ+ , evalPQ+ , withConnection+ ) where++import Control.Applicative+import Control.Category+import Control.Monad (MonadPlus(..))+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Fix (MonadFix(..))+import Control.Monad.Catch+import Control.Monad.Morph+import Control.Monad.Reader+import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..))+import UnliftIO (MonadUnliftIO(..))+import Data.ByteString (ByteString)+import Data.Functor ((<&>))+import Data.Hashable+import Data.Kind+import Data.String+import Generics.SOP+import PostgreSQL.Binary.Encoding (encodingBytes)+import Prelude hiding (id, (.))++import qualified Control.Monad.Fail as Fail+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified PostgreSQL.Binary.Encoding as Encoding++import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Session.Connection+import Squeal.PostgreSQL.Session.Encode+import Squeal.PostgreSQL.Session.Exception+import Squeal.PostgreSQL.Session.Indexed+import Squeal.PostgreSQL.Session.Oid+import Squeal.PostgreSQL.Session.Monad+import Squeal.PostgreSQL.Session.Result+import Squeal.PostgreSQL.Session.Statement+import Squeal.PostgreSQL.Type.Schema++-- | We keep track of the schema via an Atkey indexed state monad transformer,+-- `PQ`.+newtype PQ+ (db0 :: SchemasType)+ (db1 :: SchemasType)+ (m :: Type -> Type)+ (x :: Type) =+ PQ { unPQ :: K LibPQ.Connection db0 -> m (K x db1) }++instance Monad m => Functor (PQ db0 db1 m) where+ fmap f (PQ pq) = PQ $ \ conn -> do+ K x <- pq conn+ return $ K (f x)++-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.+runPQ+ :: Functor m+ => PQ db0 db1 m x+ -> K LibPQ.Connection db0+ -> m (x, K LibPQ.Connection db1)+runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn+ -- K x <- pq conn+ -- return (x, K (unK conn))++-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.+execPQ+ :: Functor m+ => PQ db0 db1 m x+ -> K LibPQ.Connection db0+ -> m (K LibPQ.Connection db1)+execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn++-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.+evalPQ+ :: Functor m+ => PQ db0 db1 m x+ -> K LibPQ.Connection db0+ -> m x+evalPQ (PQ pq) conn = unK <$> pq conn++instance IndexedMonadTrans PQ where++ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do+ K f' <- f conn+ K x' <- x (K (unK conn))+ return $ K (f' x')++ pqBind f (PQ x) = PQ $ \ conn -> do+ K x' <- x conn+ unPQ (f x') (K (unK conn))++instance IndexedMonadTransPQ PQ where++ define (UnsafeDefinition q) = PQ $ \ (K conn) -> liftIO $ do+ resultMaybe <- LibPQ.exec conn q+ case resultMaybe of+ Nothing -> throwM $ ConnectionException "LibPQ.exec"+ Just result -> K <$> okResult_ result++instance (MonadIO io, db0 ~ db, db1 ~ db) => MonadPQ db (PQ db0 db1 io) where++ executeParams (Manipulation encode decode (UnsafeManipulation q)) x =+ PQ $ \ kconn@(K conn) -> liftIO $ do+ let+ formatParam+ :: forall param. OidOfNull db param+ => K (Maybe Encoding.Encoding) param+ -> IO (K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param)+ formatParam (K maybeEncoding) = do+ oid <- runReaderT (oidOfNull @db @param) kconn+ return . K $ maybeEncoding <&> \encoding ->+ (oid, encodingBytes encoding, LibPQ.Binary)+ encodedParams <- runReaderT (runEncodeParams encode x) kconn+ formattedParams <- hcollapse <$>+ hctraverse' (Proxy @(OidOfNull db)) formatParam encodedParams+ resultMaybe <-+ LibPQ.execParams conn (q <> ";") formattedParams LibPQ.Binary+ case resultMaybe of+ Nothing -> throwM $ ConnectionException "LibPQ.execParams"+ Just result -> do+ okResult_ result+ return $ K (Result decode result)+ executeParams (Query encode decode q) x =+ executeParams (Manipulation encode decode (queryStatement q)) x++ prepare (Manipulation encode decode (UnsafeManipulation q :: Manipulation '[] db params row)) = do+ let+ statementNum = fromString $ case show (hash q) of+ '-':num -> "negative_" <> num+ num -> num++ prepName = "prepared_statement_" <> statementNum++ prepare' = PQ $ \ kconn@(K conn) -> liftIO $ do+ let+ oidOfParam :: forall p. OidOfNull db p => (IO :.: K LibPQ.Oid) p+ oidOfParam = Comp $ K <$> runReaderT (oidOfNull @db @p) kconn+ oidsOfParams :: NP (IO :.: K LibPQ.Oid) params+ oidsOfParams = hcpure (Proxy @(OidOfNull db)) oidOfParam+ oids <- hcollapse <$> hsequence' oidsOfParams+ prepResultMaybe <- LibPQ.prepare conn prepName (q <> ";") (Just oids)+ case prepResultMaybe of+ Nothing -> throwM $ ConnectionException "LibPQ.prepare"+ Just prepResult -> K <$> okResult_ prepResult++ deallocate' = manipulate_ . UnsafeManipulation $+ "DEALLOCATE" <+> prepName++ runPrepared' params = PQ $ \ kconn@(K conn) -> liftIO $ do+ encodedParams <- runReaderT (runEncodeParams encode params) kconn+ let+ formatParam encoding = (encodingBytes encoding, LibPQ.Binary)+ formattedParams =+ [ formatParam <$> maybeParam+ | maybeParam <- hcollapse encodedParams+ ]+ resultMaybe <-+ LibPQ.execPrepared conn prepName formattedParams LibPQ.Binary+ case resultMaybe of+ Nothing -> throwM $ ConnectionException "LibPQ.runPrepared"+ Just result -> do+ okResult_ result+ return . K $ Result decode result++ prepare'+ return $ Prepared runPrepared' deallocate'++ prepare (Query encode decode q) = prepare (Manipulation encode decode (queryStatement q))++instance (Monad m, db0 ~ db1)+ => Applicative (PQ db0 db1 m) where+ pure x = PQ $ \ _conn -> pure (K x)+ (<*>) = pqAp++instance (Monad m, db0 ~ db1)+ => Monad (PQ db0 db1 m) where+ return = pure+ (>>=) = flip pqBind++instance (MonadFail m, db0 ~ db1)+ => Fail.MonadFail (PQ db0 db1 m) where+ fail = lift . Fail.fail++instance db0 ~ db1 => MFunctor (PQ db0 db1) where+ hoist f (PQ pq) = PQ (f . pq)++instance db0 ~ db1 => MonadTrans (PQ db0 db1) where+ lift m = PQ $ \ _conn -> do+ x <- m+ return (K x)++instance db0 ~ db1 => MMonad (PQ db0 db1) where+ embed f (PQ pq) = PQ $ \ conn -> do+ evalPQ (f (pq conn)) conn++instance (MonadIO m, schema0 ~ schema1)+ => MonadIO (PQ schema0 schema1 m) where+ liftIO = lift . liftIO++instance (MonadUnliftIO m, db0 ~ db1)+ => MonadUnliftIO (PQ db0 db1 m) where+ withRunInIO+ :: ((forall a . PQ db0 schema1 m a -> IO a) -> IO b)+ -> PQ db0 schema1 m b+ withRunInIO inner = PQ $ \conn ->+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn)++instance (MonadBase b m)+ => MonadBase b (PQ schema schema m) where+ liftBase = lift . liftBase++instance db0 ~ db1 => MonadTransControl (PQ db0 db1) where+ type StT (PQ db0 db1) a = a+ liftWith f = PQ $ \conn -> K <$> (f $ \pq -> unK <$> unPQ pq conn)+ restoreT ma = PQ . const $ K <$> ma++-- | A snapshot of the state of a `PQ` computation, used in MonadBaseControl Instance+type PQRun schema =+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)++instance (MonadBaseControl b m, schema0 ~ schema1)+ => MonadBaseControl b (PQ schema0 schema1 m) where+ type StM (PQ schema0 schema1 m) x = StM m (K x schema0)+ restoreM = PQ . const . restoreM+ liftBaseWith f =+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run+ where+ pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a+ pqliftWith g = PQ $ \ conn ->+ fmap K (g $ \ pq -> unPQ pq conn)++instance (MonadThrow m, db0 ~ db1)+ => MonadThrow (PQ db0 db1 m) where+ throwM = lift . throwM++instance (MonadCatch m, db0 ~ db1)+ => MonadCatch (PQ db0 db1 m) where+ catch (PQ m) f = PQ $ \k -> m k `catch` \e -> unPQ (f e) k++instance (MonadMask m, db0 ~ db1)+ => MonadMask (PQ db0 db1 m) where+ mask a = PQ $ \e -> mask $ \u -> unPQ (a $ q u) e+ where q u (PQ b) = PQ (u . b)++ uninterruptibleMask a =+ PQ $ \k -> uninterruptibleMask $ \u -> unPQ (a $ q u) k+ where q u (PQ b) = PQ (u . b)++ generalBracket acquire release use = PQ $ \k ->+ K <$> generalBracket+ (unK <$> unPQ acquire k)+ (\resource exitCase -> unK <$> unPQ (release resource exitCase) k)+ (\resource -> unK <$> unPQ (use resource) k)++instance (Monad m, Semigroup r, db0 ~ db1) => Semigroup (PQ db0 db1 m r) where+ f <> g = pqAp (fmap (<>) f) g++instance (Monad m, Monoid r, db0 ~ db1) => Monoid (PQ db0 db1 m r) where+ mempty = pure mempty++instance MonadFix m => MonadFix (PQ db db m) where+ mfix f = PQ $ \conn -> mfix $ \ (K a) -> K <$> evalPQ (f a) conn++instance (Monad m, Alternative m, db0 ~ db1)+ => Alternative (PQ db0 db1 m) where+ empty = lift empty+ altL <|> altR = PQ $ \ conn -> fmap K $+ evalPQ altL conn <|> evalPQ altR conn++instance (MonadPlus m, db0 ~ db1) => MonadPlus (PQ db0 db1 m)++-- | Do `connectdb` and `finish` before and after a computation.+withConnection+ :: forall db0 db1 io x+ . (MonadIO io, MonadMask io)+ => ByteString+ -> PQ db0 db1 io x+ -> io x+withConnection connString action =+ unK <$> bracket (connectdb connString) finish (unPQ action)++okResult_ :: MonadIO io => LibPQ.Result -> io ()+okResult_ result = liftIO $ do+ status <- LibPQ.resultStatus result+ case status of+ LibPQ.CommandOk -> return ()+ LibPQ.TuplesOk -> return ()+ _ -> do+ stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate+ case stateCodeMaybe of+ Nothing -> throwM $ ConnectionException "LibPQ.resultErrorField"+ Just stateCode -> do+ msgMaybe <- LibPQ.resultErrorMessage result+ case msgMaybe of+ Nothing -> throwM $ ConnectionException "LibPQ.resultErrorMessage"+ Just msg -> throwM . SQLException $ SQLState status stateCode msg
+ src/Squeal/PostgreSQL/Session/Connection.hs view
@@ -0,0 +1,78 @@+{-|+Module: Squeal.PostgreSQL.Session.Connection+Description: database connections+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++database connections+-}++{-# LANGUAGE+ DataKinds+ , PolyKinds+ , RankNTypes+ , TypeOperators+#-}++module Squeal.PostgreSQL.Session.Connection+ ( LibPQ.Connection+ , connectdb+ , finish+ , lowerConnection+ , SOP.K (..)+ , SOP.unK+ ) where++import Control.Monad.IO.Class+import Data.ByteString (ByteString)++import Squeal.PostgreSQL.Type.Schema++import qualified Generics.SOP as SOP+import qualified Database.PostgreSQL.LibPQ as LibPQ++-- $setup+-- >>> import Squeal.PostgreSQL++{- | 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 -XPolyKinds+>>> :set -XTypeOperators+>>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]]+>>> :set -XTypeApplications+>>> :set -XOverloadedStrings+>>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"++Note that, for now, squeal doesn't offer any protection from connecting+with the wrong schema!+-}+connectdb+ :: forall (db :: SchemasType) io+ . MonadIO io+ => ByteString -- ^ conninfo+ -> io (SOP.K LibPQ.Connection db)+connectdb = fmap SOP.K . liftIO . LibPQ.connectdb++-- | Closes the connection to the server.+finish :: MonadIO io => SOP.K LibPQ.Connection db -> io ()+finish = liftIO . LibPQ.finish . SOP.unK++-- | Safely `lowerConnection` to a smaller schema.+lowerConnection+ :: SOP.K LibPQ.Connection (schema ': db)+ -> SOP.K LibPQ.Connection db+lowerConnection (SOP.K conn) = SOP.K conn
+ src/Squeal/PostgreSQL/Session/Decode.hs view
@@ -0,0 +1,698 @@+{-|+Module: Squeal.PostgreSQL.Session.Decode+Description: decoding of result values+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++decoding of result values+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , CPP+ , DataKinds+ , DerivingStrategies+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Session.Decode+ ( -- * Decode Types+ FromPG (..)+ , devalue+ , rowValue+ , enumValue+ -- * Decode Rows+ , DecodeRow (..)+ , decodeRow+ , runDecodeRow+ , GenericRow (..)+ , genericProductRow+ , appendRows+ , consRow+ , ArrayField (..)+ -- * Decoding Classes+ , FromValue (..)+ , FromField (..)+ , FromAliasedValue (..)+ , FromArray (..)+ , StateT (..)+ , ExceptT (..)+ ) where++import BinaryParser+import Control.Applicative+import Control.Arrow+import Control.Monad+#if MIN_VERSION_base(4,13,0)+#else+import Control.Monad.Fail+#endif+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State.Strict+import Control.Monad.Trans.Maybe+import Data.Bits+import Data.Coerce (coerce)+import Data.Functor.Constant (Constant(Constant))+import Data.Int (Int16, Int32, Int64)+#if MIN_VERSION_postgresql_binary(0, 14, 0)+import Data.IP (IPRange)+#else+import Network.IP.Addr (NetAddr, IP)+#endif+import Data.Kind+import Data.Scientific (Scientific)+import Data.String (fromString)+import Data.Text (Text)+import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)+import Data.UUID.Types (UUID)+import Data.Vector (Vector)+import Database.PostgreSQL.LibPQ (Oid(Oid))+import GHC.OverloadedLabels+import GHC.TypeLits+import PostgreSQL.Binary.Decoding hiding (Composite)+import Unsafe.Coerce++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.Text.Lazy as Lazy (Text)+import qualified Data.Text as Strict (Text)+import qualified Data.Text as Strict.Text+import qualified Data.Vector as Vector+import qualified Generics.SOP as SOP+import qualified Generics.SOP.Record as SOP++import Squeal.PostgreSQL.Expression.Range+import Squeal.PostgreSQL.Type+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.PG+import Squeal.PostgreSQL.Type.Schema++-- | Converts a `Value` type from @postgresql-binary@ for use in+-- the `fromPG` method of `FromPG`.+devalue :: Value x -> StateT Strict.ByteString (Except Strict.Text) x+devalue = unsafeCoerce++revalue :: StateT Strict.ByteString (Except Strict.Text) x -> Value x+revalue = unsafeCoerce++{- |+>>> :set -XTypeFamilies+>>> :{+data Complex = Complex+ { real :: Double+ , imaginary :: Double+ }+instance IsPG Complex where+ type PG Complex = 'PGcomposite '[+ "re" ::: 'NotNull 'PGfloat8,+ "im" ::: 'NotNull 'PGfloat8]+instance FromPG Complex where+ fromPG = rowValue $ do+ re <- #re+ im <- #im+ return Complex {real = re, imaginary = im}+:}+-}+rowValue+ :: (PG y ~ 'PGcomposite row, SOP.SListI row)+ => DecodeRow row y -- ^ fields+ -> StateT Strict.ByteString (Except Strict.Text) y+rowValue decoder = devalue $+ let+ -- <number of fields: 4 bytes>+ -- [for each field]+ -- <OID of field's type: sizeof(Oid) bytes>+ -- [if value is NULL]+ -- <-1: 4 bytes>+ -- [else]+ -- <length of value: 4 bytes>+ -- <value: <length> bytes>+ -- [end if]+ -- [end for]+ comp = valueParser $ do+ unitOfSize 4+ SOP.hsequence' $ SOP.hpure $ SOP.Comp $ do+ unitOfSize 4+ len :: Int32 <- sized 4 int+ if len == -1+ then return (SOP.K Nothing)+ else SOP.K . Just <$> bytesOfSize (fromIntegral len)+ in fn (runDecodeRow decoder <=< comp)++-- | A `FromPG` constraint gives a parser from the binary format of+-- a PostgreSQL `PGType` into a Haskell `Type`.+class IsPG y => FromPG y where+ {- |+ >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XDerivingStrategies -XDerivingVia -XUndecidableInstances+ >>> import GHC.Generics as GHC+ >>> :{+ newtype UserId = UserId { getId :: Int64 }+ deriving newtype (IsPG, FromPG)+ :}++ >>> :{+ data Complex = Complex+ { real :: Double+ , imaginary :: Double+ } deriving stock GHC.Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving (IsPG, FromPG) via Composite Complex+ :}++ >>> :{+ data Direction = North | South | East | West+ deriving stock GHC.Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving (IsPG, FromPG) via Enumerated Direction+ :}++ -}+ fromPG :: StateT Strict.ByteString (Except Strict.Text) y+instance FromPG Bool where+ fromPG = devalue bool+instance FromPG Int16 where+ fromPG = devalue int+instance FromPG Int32 where+ fromPG = devalue int+instance FromPG Int64 where+ fromPG = devalue int+instance FromPG Oid where+ fromPG = devalue $ Oid <$> int+instance FromPG Float where+ fromPG = devalue float4+instance FromPG Double where+ fromPG = devalue float8+instance FromPG Scientific where+ fromPG = devalue numeric+instance FromPG Money where+ fromPG = devalue $ Money <$> int+instance FromPG UUID where+ fromPG = devalue uuid+#if MIN_VERSION_postgresql_binary(0, 14, 0)+instance FromPG IPRange where fromPG = devalue inet+#else+instance FromPG (NetAddr IP) where fromPG = devalue inet+#endif+instance FromPG Char where+ fromPG = devalue char+instance FromPG Strict.Text where+ fromPG = devalue text_strict+instance FromPG Lazy.Text where+ fromPG = devalue text_lazy+instance FromPG String where+ fromPG = devalue $ Strict.Text.unpack <$> text_strict+instance FromPG Strict.ByteString where+ fromPG = devalue bytea_strict+instance FromPG Lazy.ByteString where+ fromPG = devalue bytea_lazy+instance KnownNat n => FromPG (VarChar n) where+ fromPG = devalue $ text_strict >>= \t ->+ case varChar t of+ Nothing -> throwError $ Strict.Text.pack $ concat+ [ "Source for VarChar has wrong length"+ , "; expected length "+ , show (natVal (SOP.Proxy @n))+ , ", actual length "+ , show (Strict.Text.length t)+ , "."+ ]+ Just x -> pure x+instance KnownNat n => FromPG (FixChar n) where+ fromPG = devalue $ text_strict >>= \t ->+ case fixChar t of+ Nothing -> throwError $ Strict.Text.pack $ concat+ [ "Source for FixChar has wrong length"+ , "; expected length "+ , show (natVal (SOP.Proxy @n))+ , ", actual length "+ , show (Strict.Text.length t)+ , "."+ ]+ Just x -> pure x+instance FromPG x => FromPG (Const x tag) where+ fromPG = coerce $ fromPG @x+instance FromPG x => FromPG (SOP.K x tag) where+ fromPG = coerce $ fromPG @x+instance FromPG x => FromPG (Constant x tag) where+ fromPG = coerce $ fromPG @x+instance FromPG Day where+ fromPG = devalue date+instance FromPG TimeOfDay where+ fromPG = devalue time_int+instance FromPG (TimeOfDay, TimeZone) where+ fromPG = devalue timetz_int+instance FromPG LocalTime where+ fromPG = devalue timestamp_int+instance FromPG UTCTime where+ fromPG = devalue timestamptz_int+instance FromPG DiffTime where+ fromPG = devalue interval_int+instance FromPG Aeson.Value where+ fromPG = devalue json_ast+instance Aeson.FromJSON x => FromPG (Json x) where+ fromPG = devalue $ Json <$>+ json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)+instance Aeson.FromJSON x => FromPG (Jsonb x) where+ fromPG = devalue $ Jsonb <$>+ jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)+instance (FromArray '[] ty y, ty ~ NullPG y)+ => FromPG (VarArray (Vector y)) where+ fromPG =+ let+ rep n x = VarArray <$> Vector.replicateM n x+ in+ devalue . array $ dimensionArray rep+ (fromArray @'[] @(NullPG y))+instance (FromArray '[] ty y, ty ~ NullPG y)+ => FromPG (VarArray [y]) where+ fromPG =+ let+ rep n x = VarArray <$> replicateM n x+ in+ devalue . array $ dimensionArray rep+ (fromArray @'[] @(NullPG y))+instance FromArray dims ty y => FromPG (FixArray y) where+ fromPG = devalue $ FixArray <$> array (fromArray @dims @ty @y)+instance+ ( SOP.IsEnumType y+ , SOP.HasDatatypeInfo y+ , LabelsPG y ~ labels+ ) => FromPG (Enumerated y) where+ fromPG =+ let+ greadConstructor+ :: SOP.All ((~) '[]) xss+ => NP SOP.ConstructorInfo xss+ -> String+ -> Maybe (SOP.SOP SOP.I xss)+ greadConstructor Nil _ = Nothing+ greadConstructor (constructor :* constructors) name =+ if name == SOP.constructorName constructor+ then Just (SOP.SOP (SOP.Z Nil))+ else SOP.SOP . SOP.S . SOP.unSOP <$>+ greadConstructor constructors name+ in+ devalue+ $ fmap Enumerated+ . enum+ $ fmap SOP.to+ . greadConstructor+ (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @y)))+ . Strict.Text.unpack+instance+ ( SOP.IsRecord y ys+ , SOP.AllZip FromField row ys+ , RowPG y ~ row+ ) => FromPG (Composite y) where+ fromPG = rowValue (Composite <$> genericRow)+instance FromPG y => FromPG (Range y) where+ fromPG = devalue $ do+ flag <- byte+ if testBit flag 0 then return Empty else do+ lower <-+ if testBit flag 3+ then return Infinite+ else do+ len <- sized 4 int+ l <- sized len (revalue fromPG)+ return $ if testBit flag 1 then Closed l else Open l+ upper <-+ if testBit flag 4+ then return Infinite+ else do+ len <- sized 4 int+ l <- sized len (revalue fromPG)+ return $ if testBit flag 2 then Closed l else Open l+ return $ NonEmpty lower upper++-- | A `FromValue` constraint lifts the `FromPG` parser+-- to a decoding of a @NullityType@ to a `Type`,+-- decoding `Null`s to `Maybe`s. You should not define instances for+-- `FromValue`, just use the provided instances.+class FromValue (ty :: NullType) (y :: Type) where+ fromValue :: Maybe Strict.ByteString -> Either Strict.Text y+instance (FromPG y, pg ~ PG y) => FromValue ('NotNull pg) y where+ fromValue = \case+ Nothing -> throwError "fromField: saw NULL when expecting NOT NULL"+ Just bytestring -> valueParser (revalue fromPG) bytestring+instance (FromPG y, pg ~ PG y) => FromValue ('Null pg) (Maybe y) where+ fromValue = \case+ Nothing -> return Nothing+ Just bytestring -> fmap Just $ valueParser (revalue fromPG) bytestring++-- | A `FromField` constraint lifts the `FromPG` parser+-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,+-- decoding `Null`s to `Maybe`s. You should not define instances for+-- `FromField`, just use the provided instances.+class FromField (field :: (Symbol, NullType)) (y :: (Symbol, Type)) where+ fromField :: Maybe Strict.ByteString -> Either Strict.Text (SOP.P y)+instance (FromValue ty y, fld0 ~ fld1)+ => FromField (fld0 ::: ty) (fld1 ::: y) where+ fromField = fmap SOP.P . fromValue @ty++-- | A `FromArray` constraint gives a decoding to a Haskell `Type`+-- from the binary format of a PostgreSQL fixed-length array.+-- You should not define instances for+-- `FromArray`, just use the provided instances.+class FromArray (dims :: [Nat]) (ty :: NullType) (y :: Type) where+ fromArray :: Array y+instance (FromPG y, pg ~ PG y) => FromArray '[] ('NotNull pg) y where+ fromArray = valueArray (revalue fromPG)+instance (FromPG y, pg ~ PG y) => FromArray '[] ('Null pg) (Maybe y) where+ fromArray = nullableValueArray (revalue fromPG)+instance+ ( SOP.IsProductType product ys+ , Length ys ~ dim+ , SOP.All ((~) y) ys+ , FromArray dims ty y )+ => FromArray (dim ': dims) ty product where+ fromArray =+ let+ rep _ = fmap (SOP.to . SOP.SOP . SOP.Z) . replicateMN+ in+ dimensionArray rep (fromArray @dims @ty @y)++replicateMN+ :: forall x xs m. (SOP.All ((~) x) xs, Monad m, SOP.SListI xs)+ => m x -> m (SOP.NP SOP.I xs)+replicateMN mx = SOP.hsequence' $+ SOP.hcpure (SOP.Proxy :: SOP.Proxy ((~) x)) (SOP.Comp (SOP.I <$> mx))++{- |+`DecodeRow` describes a decoding of a PostgreSQL `RowType`+into a Haskell `Type`.++`DecodeRow` has an interface given by the classes+`Functor`, `Applicative`, `Alternative`, `Monad`,+`MonadPlus`, `MonadError` `Strict.Text`, and `IsLabel`.++>>> :set -XOverloadedLabels+>>> :{+let+ decode :: DecodeRow+ '[ "fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)]+ (Int16, Char)+ decode = (,) <$> #fst <*> #snd+in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)+:}+Right (1,'a')++There is also an `IsLabel` instance for `MaybeT` `DecodeRow`s, useful+for decoding outer joined rows.++>>> :{+let+ decode :: DecodeRow+ '[ "fst" ::: 'Null 'PGint2, "snd" ::: 'Null ('PGchar 1)]+ (Maybe (Int16, Char))+ decode = runMaybeT $ (,) <$> #fst <*> #snd+in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)+:}+Right (Just (1,'a'))++-}+newtype DecodeRow (row :: RowType) (y :: Type) = DecodeRow+ { unDecodeRow :: ReaderT+ (SOP.NP (SOP.K (Maybe Strict.ByteString)) row) (Except Strict.Text) y }+ deriving newtype+ ( Functor+ , Applicative+ , Alternative+ , Monad+ , MonadPlus+ , MonadError Strict.Text )+instance MonadFail (DecodeRow row) where+ fail = throwError . fromString++-- | Run a `DecodeRow`.+runDecodeRow+ :: DecodeRow row y+ -> SOP.NP (SOP.K (Maybe Strict.ByteString)) row+ -> Either Strict.Text y+runDecodeRow = fmap runExcept . runReaderT . unDecodeRow++{- | Append two row decoders with a combining function.++>>> import GHC.Generics as GHC+>>> :{+data L = L {fst :: Int16, snd :: Char}+ deriving stock (GHC.Generic, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+data R = R {thrd :: Bool, frth :: Bool}+ deriving stock (GHC.Generic, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+type Row = '[+ "fst" ::: 'NotNull 'PGint2,+ "snd" ::: 'NotNull ('PGchar 1),+ "thrd" ::: 'NotNull 'PGbool,+ "frth" ::: 'NotNull 'PGbool]+:}++>>> :{+let+ decode :: DecodeRow Row (L,R)+ decode = appendRows (,) genericRow genericRow+ row4 =+ SOP.K (Just "\NUL\SOH") :*+ SOP.K (Just "a") :*+ SOP.K (Just "\NUL") :*+ SOP.K (Just "\NUL") :* Nil+in runDecodeRow decode row4+:}+Right (L {fst = 1, snd = 'a'},R {thrd = False, frth = False})+-}+appendRows+ :: SOP.SListI left+ => (l -> r -> z) -- ^ combining function+ -> DecodeRow left l -- ^ left decoder+ -> DecodeRow right r -- ^ right decoder+ -> DecodeRow (Join left right) z+appendRows f decL decR = decodeRow $ \row -> case disjoin row of+ (rowL, rowR) -> f <$> runDecodeRow decL rowL <*> runDecodeRow decR rowR++{- | Cons a column and a row decoder with a combining function.++>>> :{+let+ decode :: DecodeRow+ '["fst" ::: 'NotNull 'PGtext, "snd" ::: 'NotNull 'PGint2, "thrd" ::: 'NotNull ('PGchar 1)]+ (String, (Int16, Char))+ decode = consRow (,) #fst (consRow (,) #snd #thrd)+in runDecodeRow decode (SOP.K (Just "hi") :* SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)+:}+Right ("hi",(1,'a'))+-}+consRow+ :: FromValue head h+ => (h -> t -> z) -- ^ combining function+ -> Alias col -- ^ alias of head+ -> DecodeRow tail t -- ^ tail decoder+ -> DecodeRow (col ::: head ': tail) z+consRow f _ dec = decodeRow $ \case+ (SOP.K h :: SOP.K (Maybe Strict.ByteString) (col ::: head)) :* t+ -> f <$> fromValue @head h <*> runDecodeRow dec t++-- | Smart constructor for a `DecodeRow`.+decodeRow+ :: (SOP.NP (SOP.K (Maybe Strict.ByteString)) row -> Either Strict.Text y)+ -> DecodeRow row y+decodeRow dec = DecodeRow . ReaderT $ liftEither . dec+instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty y)+ => IsLabel fld (DecodeRow (fld ::: ty ': row) y) where+ fromLabel = decodeRow $ \(SOP.K b SOP.:* _) -> do+ let+ flderr = mconcat+ [ "field name: "+ , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "+ ]+ left (flderr <>) $ fromValue @ty b+instance {-# OVERLAPPABLE #-} IsLabel fld (DecodeRow row y)+ => IsLabel fld (DecodeRow (field ': row) y) where+ fromLabel = decodeRow $ \(_ SOP.:* bs) ->+ runDecodeRow (fromLabel @fld) bs+instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty (Maybe y))+ => IsLabel fld (MaybeT (DecodeRow (fld ::: ty ': row)) y) where+ fromLabel = MaybeT . decodeRow $ \(SOP.K b SOP.:* _) -> do+ let+ flderr = mconcat+ [ "field name: "+ , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "+ ]+ left (flderr <>) $ fromValue @ty b+instance {-# OVERLAPPABLE #-} IsLabel fld (MaybeT (DecodeRow row) y)+ => IsLabel fld (MaybeT (DecodeRow (field ': row)) y) where+ fromLabel = MaybeT . decodeRow $ \(_ SOP.:* bs) ->+ runDecodeRow (runMaybeT (fromLabel @fld)) bs++{- | Utility for decoding array fields in a `DecodeRow`,+accessed via overloaded labels.+-}+newtype ArrayField row y = ArrayField+ { runArrayField+ :: StateT Strict.ByteString (Except Strict.Text) y+ -> DecodeRow row [y]+ }+instance {-# OVERLAPPING #-}+ ( KnownSymbol fld+ , PG y ~ ty+ , arr ~ 'NotNull ('PGvararray ('NotNull ty))+ ) => IsLabel fld (ArrayField (fld ::: arr ': row) y) where+ fromLabel = ArrayField $ \yval ->+ decodeRow $ \(SOP.K bytesMaybe SOP.:* _) -> do+ let+ flderr = mconcat+ [ "field name: "+ , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "+ ]+ yarr+ = devalue+ . array+ . dimensionArray replicateM+ . valueArray+ . revalue+ $ yval+ case bytesMaybe of+ Nothing -> Left (flderr <> "encountered unexpected NULL")+ Just bytes -> runExcept (evalStateT yarr bytes)+instance {-# OVERLAPPABLE #-} IsLabel fld (ArrayField row y)+ => IsLabel fld (ArrayField (field ': row) y) where+ fromLabel = ArrayField $ \yval ->+ decodeRow $ \(_ SOP.:* bytess) ->+ runDecodeRow (runArrayField (fromLabel @fld) yval) bytess++-- | A `GenericRow` constraint to ensure that a Haskell type+-- is a record type,+-- has a `RowPG`,+-- and all its fields and can be decoded from corresponding Postgres fields.+class+ ( SOP.IsRecord y ys+ , row ~ RowPG y+ , SOP.AllZip FromField row ys+ ) => GenericRow row y ys where+ {- | Row decoder for `SOP.Generic` records.++ >>> import qualified GHC.Generics as GHC+ >>> import qualified Generics.SOP as SOP+ >>> data Two = Two {frst :: Int16, scnd :: String} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)+ >>> :{+ let+ decode :: DecodeRow '[ "frst" ::: 'NotNull 'PGint2, "scnd" ::: 'NotNull 'PGtext] Two+ decode = genericRow+ in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil)+ :}+ Right (Two {frst = 2, scnd = "two"})+ -}+ genericRow :: DecodeRow row y+instance+ ( row ~ RowPG y+ , SOP.IsRecord y ys+ , SOP.AllZip FromField row ys+ ) => GenericRow row y ys where+ genericRow+ = DecodeRow+ . ReaderT+ $ fmap SOP.fromRecord+ . SOP.hsequence'+ . SOP.htrans (SOP.Proxy @FromField) runField+ where+ runField+ :: forall ty z. FromField ty z+ => SOP.K (Maybe Strict.ByteString) ty+ -> (Except Strict.Text SOP.:.: SOP.P) z+ runField+ = SOP.Comp+ . liftEither+ . fromField @ty+ . SOP.unK++{- | Assistant class for `genericProductRow`,+this class forgets the name of a field while decoding it.+-}+class FromAliasedValue (field :: (Symbol, NullType)) (y :: Type) where+ fromAliasedValue :: Maybe Strict.ByteString -> Either Strict.Text y+instance FromValue ty y => FromAliasedValue (fld ::: ty) y where+ fromAliasedValue = fromValue @ty++{- | Positionally `DecodeRow`. More general than `genericRow`,+which matches records both positionally and by field name,+`genericProductRow` matches records _or_ tuples purely positionally.++>>> import qualified GHC.Generics as GHC+>>> import qualified Generics.SOP as SOP+>>> :{+let+ decode :: DecodeRow '[ "foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGtext] (Int16, String)+ decode = genericProductRow+in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil)+:}+Right (2,"two")+-}+genericProductRow+ :: ( SOP.IsProductType y ys+ , SOP.AllZip FromAliasedValue row ys+ )+ => DecodeRow row y+genericProductRow+ = DecodeRow+ . ReaderT+ $ fmap SOP.productTypeTo+ . SOP.hsequence'+ . SOP.htrans (SOP.Proxy @FromAliasedValue) runField+ where+ runField+ :: forall ty z. FromAliasedValue ty z+ => SOP.K (Maybe Strict.ByteString) ty+ -> (Except Strict.Text SOP.:.: SOP.I) z+ runField+ = SOP.Comp+ . fmap SOP.I+ . liftEither+ . fromAliasedValue @ty+ . SOP.unK++{- |+>>> :{+data Dir = North | East | South | West+instance IsPG Dir where+ type PG Dir = 'PGenum '["north", "south", "east", "west"]+instance FromPG Dir where+ fromPG = enumValue $+ label @"north" North :*+ label @"south" South :*+ label @"east" East :*+ label @"west" West+:}+-}+enumValue+ :: (SOP.All KnownSymbol labels, PG y ~ 'PGenum labels)+ => NP (SOP.K y) labels -- ^ labels+ -> StateT Strict.ByteString (Except Strict.Text) y+enumValue = devalue . enum . labels+ where+ labels+ :: SOP.All KnownSymbol labels+ => NP (SOP.K y) labels+ -> Text -> Maybe y+ labels = \case+ Nil -> \_ -> Nothing+ ((y :: SOP.K y label) :* ys) -> \ str ->+ if str == fromString (symbolVal (SOP.Proxy @label))+ then Just (SOP.unK y)+ else labels ys str
+ src/Squeal/PostgreSQL/Session/Encode.hs view
@@ -0,0 +1,681 @@+{-|+Module: Squeal.PostgreSQL.Session.Encode+Description: encoding of statement parameters+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++encoding of statement parameters+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , CPP+ , DataKinds+ , DefaultSignatures+ , FlexibleContexts+ , FlexibleInstances+ , LambdaCase+ , MultiParamTypeClasses+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Session.Encode+ ( -- * Encode Parameters+ EncodeParams (..)+ , GenericParams (..)+ , nilParams+ , (.*)+ , (*.)+ , aParam+ , appendParams+ , enumParam+ , rowParam+ , genericRowParams+ , (.#)+ , (#.)+ -- * Encoding Classes+ , ToPG (..)+ , ToParam (..)+ , ToField (..)+ , ToArray (..)+ ) where++import ByteString.StrictBuilder+import Control.Monad+import Control.Monad.Reader+import Data.Bits+import Data.ByteString as Strict (ByteString)+import Data.ByteString.Lazy as Lazy (ByteString)+import Data.Coerce (coerce)+import Data.Functor.Const (Const(Const))+import Data.Functor.Constant (Constant(Constant))+import Data.Functor.Contravariant+import Data.Int (Int16, Int32, Int64)+#if MIN_VERSION_postgresql_binary(0, 14, 0)+import Data.IP (IPRange)+#else+import Network.IP.Addr (NetAddr, IP)+#endif+import Data.Kind+import Data.Scientific (Scientific)+import Data.Text as Strict (Text)+import Data.Text.Lazy as Lazy (Text)+import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)+import Data.UUID.Types (UUID)+import Data.Vector (Vector)+import Data.Word (Word32)+import Foreign.C.Types (CUInt(CUInt))+import GHC.TypeLits+import PostgreSQL.Binary.Encoding hiding (Composite, field)++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as Lazy.ByteString+import qualified Data.Text as Strict.Text+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Generics.SOP as SOP+import qualified Generics.SOP.Record as SOP++import Squeal.PostgreSQL.Expression.Range+import Squeal.PostgreSQL.Session.Oid+import Squeal.PostgreSQL.Type+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.PG+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL (connectdb, finish)++-- | A `ToPG` constraint gives an encoding of a Haskell `Type` into+-- into the binary format of a PostgreSQL `PGType`.+class IsPG x => ToPG (db :: SchemasType) (x :: Type) where+ -- | >>> :set -XTypeApplications -XDataKinds+ -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+ -- >>> runReaderT (toPG @'[] False) conn+ -- "\NUL"+ --+ -- >>> runReaderT (toPG @'[] (0 :: Int16)) conn+ -- "\NUL\NUL"+ --+ -- >>> runReaderT (toPG @'[] (0 :: Int32)) conn+ -- "\NUL\NUL\NUL\NUL"+ --+ -- >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving+ -- >>> newtype UserId = UserId { getUserId :: Int64 } deriving newtype (IsPG, ToPG db)+ -- >>> runReaderT (toPG @'[] (UserId 0)) conn+ -- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"+ --+ -- >>> finish conn+ toPG :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding+instance ToPG db Bool where toPG = pure . bool+instance ToPG db Int16 where toPG = pure . int2_int16+instance ToPG db Int32 where toPG = pure . int4_int32+instance ToPG db Int64 where toPG = pure . int8_int64+instance ToPG db Oid where toPG = pure . int4_word32 . getOid+instance ToPG db Float where toPG = pure . float4+instance ToPG db Double where toPG = pure . float8+instance ToPG db Scientific where toPG = pure . numeric+instance ToPG db Money where toPG = pure . int8_int64 . cents+instance ToPG db UUID where toPG = pure . uuid+#if MIN_VERSION_postgresql_binary(0, 14, 0)+instance ToPG db IPRange where toPG = pure . inet+#else+instance ToPG db (NetAddr IP) where toPG = pure . inet+#endif+instance ToPG db Char where toPG = pure . char_utf8+instance ToPG db Strict.Text where toPG = pure . text_strict+instance ToPG db Lazy.Text where toPG = pure . text_lazy+instance ToPG db String where+ toPG = pure . text_strict . Strict.Text.pack+instance ToPG db Strict.ByteString where toPG = pure . bytea_strict+instance ToPG db Lazy.ByteString where toPG = pure . bytea_lazy+instance ToPG db (VarChar n) where toPG = pure . text_strict . getVarChar+instance ToPG db (FixChar n) where toPG = pure . text_strict . getFixChar+instance ToPG db x => ToPG db (Const x tag) where toPG = toPG @db @x . coerce+instance ToPG db x => ToPG db (SOP.K x tag) where toPG = toPG @db @x . coerce+instance ToPG db x => ToPG db (Constant x tag) where toPG = toPG @db @x . coerce+instance ToPG db Day where toPG = pure . date+instance ToPG db TimeOfDay where toPG = pure . time_int+instance ToPG db (TimeOfDay, TimeZone) where toPG = pure . timetz_int+instance ToPG db LocalTime where toPG = pure . timestamp_int+instance ToPG db UTCTime where toPG = pure . timestamptz_int+instance ToPG db DiffTime where toPG = pure . interval_int+instance ToPG db Aeson.Value where toPG = pure . json_ast+instance Aeson.ToJSON x => ToPG db (Json x) where+ toPG = pure . json_bytes+ . Lazy.ByteString.toStrict . Aeson.encode . getJson+instance Aeson.ToJSON x => ToPG db (Jsonb x) where+ toPG = pure . jsonb_bytes+ . Lazy.ByteString.toStrict . Aeson.encode . getJsonb+instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty)+ => ToPG db (VarArray [x]) where+ toPG (VarArray arr) = do+ oid <- oidOfNull @db @ty+ let+ dims = [fromIntegral (length arr)]+ nulls = arrayNulls @db @'[] @ty @x+ payload <- dimArray foldM (arrayPayload @db @'[] @ty @x) arr+ return $ encodeArray 1 nulls oid dims payload+instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty)+ => ToPG db (VarArray (Vector x)) where+ toPG (VarArray arr) = do+ oid <- oidOfNull @db @ty+ let+ dims = [fromIntegral (length arr)]+ nulls = arrayNulls @db @'[] @ty @x+ payload <- dimArray foldM (arrayPayload @db @'[] @ty @x) arr+ return $ encodeArray 1 nulls oid dims payload+instance (ToArray db dims ty x, OidOfNull db ty)+ => ToPG db (FixArray x) where+ toPG (FixArray arr) = do+ oid <- oidOfNull @db @ty+ payload <- arrayPayload @db @dims @ty arr+ let+ dims = arrayDims @db @dims @ty @x+ nulls = arrayNulls @db @dims @ty @x+ ndims = fromIntegral (length dims)+ return $ encodeArray ndims nulls oid dims payload+instance+ ( SOP.IsEnumType x+ , SOP.HasDatatypeInfo x+ , LabelsPG x ~ labels+ ) => ToPG db (Enumerated x) where+ toPG =+ let+ gshowConstructor+ :: NP SOP.ConstructorInfo xss+ -> SOP.SOP SOP.I xss+ -> String+ gshowConstructor Nil _ = ""+ gshowConstructor (constructor :* _) (SOP.SOP (SOP.Z _)) =+ SOP.constructorName constructor+ gshowConstructor (_ :* constructors) (SOP.SOP (SOP.S xs)) =+ gshowConstructor constructors (SOP.SOP xs)+ in+ pure+ . text_strict+ . Strict.Text.pack+ . gshowConstructor+ (SOP.constructorInfo (SOP.datatypeInfo (SOP.Proxy @x)))+ . SOP.from+ . getEnumerated+instance+ ( SOP.SListI fields+ , SOP.IsRecord x xs+ , SOP.AllZip (ToField db) fields xs+ , SOP.All (OidOfField db) fields+ , RowPG x ~ fields+ ) => ToPG db (Composite x) where+ toPG = rowParam (contramap getComposite genericRowParams)+instance ToPG db x => ToPG db (Range x) where+ toPG r = do+ payload <- case r of+ Empty -> return mempty+ NonEmpty lower upper -> (<>) <$> putBound lower <*> putBound upper+ return $ word8 (setFlags r 0) <> payload+ where+ putBound = \case+ Infinite -> return mempty+ Closed value -> sized <$> toPG @db value+ Open value -> sized <$> toPG @db value+ setFlags = \case+ Empty -> (`setBit` 0)+ NonEmpty lower upper ->+ setLowerFlags lower . setUpperFlags upper+ setLowerFlags = \case+ Infinite -> (`setBit` 3)+ Closed _ -> (`setBit` 1)+ Open _ -> id+ setUpperFlags = \case+ Infinite -> (`setBit` 4)+ Closed _ -> (`setBit` 2)+ Open _ -> id++-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into+-- into the binary format of a PostgreSQL `NullType`.+-- You should not define instances for `ToParam`,+-- just use the provided instances.+class ToParam (db :: SchemasType) (ty :: NullType) (x :: Type) where+ toParam :: x -> ReaderT (SOP.K LibPQ.Connection db) IO (Maybe Encoding)+instance (ToPG db x, pg ~ PG x) => ToParam db ('NotNull pg) x where+ toParam = fmap Just . toPG @db+instance (ToPG db x, pg ~ PG x) => ToParam db ('Null pg) (Maybe x) where+ toParam = maybe (pure Nothing) (fmap Just . toPG @db)++-- | A `ToField` constraint lifts the `ToPG` parser+-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,+-- encoding `Null`s to `Maybe`s. You should not define instances for+-- `ToField`, just use the provided instances.+class ToField+ (db :: SchemasType)+ (field :: (Symbol, NullType))+ (x :: (Symbol, Type)) where+ toField :: SOP.P x+ -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) field)+instance (fld0 ~ fld1, ToParam db ty x)+ => ToField db (fld0 ::: ty) (fld1 ::: x) where+ toField (SOP.P x) = SOP.K <$> toParam @db @ty x++-- | A `ToArray` constraint gives an encoding of a Haskell `Type`+-- into the binary format of a PostgreSQL fixed-length array.+-- You should not define instances for+-- `ToArray`, just use the provided instances.+class ToArray+ (db :: SchemasType)+ (dims :: [Nat])+ (ty :: NullType)+ (x :: Type) where+ arrayPayload :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding+ arrayDims :: [Int32]+ arrayNulls :: Bool+instance (ToPG db x, pg ~ PG x)+ => ToArray db '[] ('NotNull pg) x where+ arrayPayload = fmap sized . toPG @db @x+ arrayDims = []+ arrayNulls = False+instance (ToPG db x, pg ~ PG x)+ => ToArray db '[] ('Null pg) (Maybe x) where+ arrayPayload = maybe (pure null4) (fmap sized . toPG @db @x)+ arrayDims = []+ arrayNulls = True+instance+ ( SOP.IsProductType tuple xs+ , Length xs ~ dim+ , SOP.All ((~) x) xs+ , ToArray db dims ty x+ , KnownNat dim )+ => ToArray db (dim ': dims) ty tuple where+ arrayPayload+ = dimArray foldlNP (arrayPayload @db @dims @ty @x)+ . SOP.unZ . SOP.unSOP . SOP.from+ arrayDims+ = fromIntegral (natVal (SOP.Proxy @dim))+ : arrayDims @db @dims @ty @x+ arrayNulls = arrayNulls @db @dims @ty @x+foldlNP+ :: (SOP.All ((~) x) xs, Monad m)+ => (z -> x -> m z) -> z -> NP SOP.I xs -> m z+foldlNP f z = \case+ Nil -> pure z+ SOP.I x :* xs -> do+ z' <- f z x+ foldlNP f z' xs++{- |+`EncodeParams` describes an encoding of a Haskell `Type`+into a list of parameter `NullType`s or into a `RowType`.++>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+>>> :{+let+ encode :: EncodeParams '[]+ '[ 'NotNull 'PGint2, 'NotNull ('PGchar 1), 'NotNull 'PGtext]+ (Int16, (Char, String))+ encode = fst .* fst.snd *. snd.snd+in runReaderT (runEncodeParams encode (1,('a',"foo"))) conn+:}+K (Just "\NUL\SOH") :* K (Just "a") :* K (Just "foo") :* Nil++>>> :{+let+ encode :: EncodeParams '[]+ '["fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)]+ (Int16, Char)+ encode = fst `as` #fst #. snd `as` #snd+in runReaderT (runEncodeParams encode (1,'a')) conn+:}+K (Just "\NUL\SOH") :* K (Just "a") :* Nil++>>> finish conn+-}+newtype EncodeParams+ (db :: SchemasType)+ (tys :: [k])+ (x :: Type) = EncodeParams+ { runEncodeParams :: x+ -> ReaderT (SOP.K LibPQ.Connection db) IO (NP (SOP.K (Maybe Encoding)) tys) }+instance Contravariant (EncodeParams db tys) where+ contramap f (EncodeParams g) = EncodeParams (g . f)++-- | A `GenericParams` constraint to ensure that a Haskell type+-- is a product type,+-- has a `TuplePG`,+-- and all its terms have known Oids,+-- and can be encoded to corresponding Postgres types.+class+ ( SOP.IsProductType x xs+ , params ~ TuplePG x+ , SOP.All (OidOfNull db) params+ , SOP.AllZip (ToParam db) params xs+ ) => GenericParams db params x xs where+ {- | Parameter encoding for `SOP.Generic` tuples and records.++ >>> import qualified GHC.Generics as GHC+ >>> import qualified Generics.SOP as SOP+ >>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic)+ >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+ >>> :{+ let+ encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two+ encode = genericParams+ in runReaderT (runEncodeParams encode (Two 2 "two")) conn+ :}+ K (Just "\NUL\STX") :* K (Just "two") :* Nil++ >>> :{+ let+ encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] (Int16, String)+ encode = genericParams+ in runReaderT (runEncodeParams encode (2, "two")) conn+ :}+ K (Just "\NUL\STX") :* K (Just "two") :* Nil++ >>> finish conn+ -}+ genericParams :: EncodeParams db params x+instance+ ( params ~ TuplePG x+ , SOP.All (OidOfNull db) params+ , SOP.IsProductType x xs+ , SOP.AllZip (ToParam db) params xs+ ) => GenericParams db params x xs where+ genericParams = EncodeParams+ $ hctransverse (SOP.Proxy @(ToParam db)) encodeNullParam+ . SOP.unZ . SOP.unSOP . SOP.from+ where+ encodeNullParam+ :: forall ty y. ToParam db ty y+ => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty)+ encodeNullParam = fmap SOP.K . toParam @db @ty . SOP.unI++-- | Encode 0 parameters.+nilParams :: EncodeParams db '[] x+nilParams = EncodeParams $ \ _ -> pure Nil++{- | Cons a parameter encoding.++>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+>>> :{+let+ encode :: EncodeParams '[]+ '[ 'Null 'PGint4, 'NotNull 'PGtext]+ (Maybe Int32, String)+ encode = fst .* snd .* nilParams+in runReaderT (runEncodeParams encode (Nothing, "foo")) conn+:}+K Nothing :* K (Just "foo") :* Nil++>>> finish conn+-}+(.*)+ :: forall db x0 ty x tys. (ToParam db ty x0, ty ~ NullPG x0)+ => (x -> x0) -- ^ head+ -> EncodeParams db tys x -- ^ tail+ -> EncodeParams db (ty ': tys) x+f .* EncodeParams params = EncodeParams $ \x ->+ (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x+infixr 5 .*++{- | End a parameter encoding.++>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+>>> :{+let+ encode :: EncodeParams '[]+ '[ 'Null 'PGint4, 'NotNull 'PGtext, 'NotNull ('PGchar 1)]+ (Maybe Int32, String, Char)+ encode = (\(x,_,_) -> x) .* (\(_,y,_) -> y) *. (\(_,_,z) -> z)+in runReaderT (runEncodeParams encode (Nothing, "foo", 'z')) conn+:}+K Nothing :* K (Just "foo") :* K (Just "z") :* Nil++>>> finish conn+-}+(*.)+ :: forall db x x0 ty0 x1 ty1+ . ( ToParam db ty0 x0+ , ty0 ~ NullPG x0+ , ToParam db ty1 x1+ , ty1 ~ NullPG x1+ )+ => (x -> x0) -- ^ second to last+ -> (x -> x1) -- ^ last+ -> EncodeParams db '[ty0, ty1] x+f *. g = f .* g .* nilParams+infixl 8 *.++{- | Encode 1 parameter.++>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+>>> :{+let+ encode :: EncodeParams '[] '[ 'NotNull 'PGint4] Int32+ encode = aParam+in runReaderT (runEncodeParams encode 1776) conn+:}+K (Just "\NUL\NUL\ACK\240") :* Nil++>>> finish conn+-}+aParam+ :: forall db x ty. (ToParam db ty x, ty ~ NullPG x)+ => EncodeParams db '[ty] x+ -- ^ a single parameter+aParam = EncodeParams $+ fmap (\param -> SOP.K param :* Nil) . toParam @db @(NullPG x)++{- | Append parameter encodings.++>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+>>> :{+let+ encode :: EncodeParams '[]+ '[ 'NotNull 'PGint4, 'NotNull 'PGint2]+ (Int32, Int16)+ encode = contramap fst aParam `appendParams` contramap snd aParam+in runReaderT (runEncodeParams encode (1776, 2)) conn+:}+K (Just "\NUL\NUL\ACK\240") :* K (Just "\NUL\STX") :* Nil++>>> finish conn+-}+appendParams+ :: EncodeParams db params0 x -- ^ left+ -> EncodeParams db params1 x -- ^ right+ -> EncodeParams db (Join params0 params1) x+appendParams encode0 encode1 = EncodeParams $ \x -> also+ <$> runEncodeParams encode1 x+ <*> runEncodeParams encode0 x++{- |+>>> :set -XLambdaCase -XFlexibleInstances+>>> :{+data Dir = North | South | East | West+instance IsPG Dir where+ type PG Dir = 'PGenum '["north", "south", "east", "west"]+instance ToPG db Dir where+ toPG = enumParam $ \case+ North -> label @"north"+ South -> label @"south"+ East -> label @"east"+ West -> label @"west"+:}+-}+enumParam+ :: (PG x ~ 'PGenum labels, SOP.All KnownSymbol labels)+ => (x -> SOP.NS PGlabel labels)+ -- ^ match cases with enum `label`s+ -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding)+enumParam casesOf+ = return+ . text_strict+ . Strict.Text.pack+ . enumCases+ . casesOf+ where+ enumCases+ :: SOP.All KnownSymbol lbls+ => SOP.NS PGlabel lbls+ -> String+ enumCases = \case+ SOP.Z (_ :: PGlabel lbl) -> symbolVal (SOP.Proxy @lbl)+ SOP.S cases -> enumCases cases++{- |+>>> :set -XTypeFamilies -XFlexibleInstances+>>> :{+data Complex = Complex+ { real :: Double+ , imaginary :: Double+ }+instance IsPG Complex where+ type PG Complex = 'PGcomposite '[+ "re" ::: 'NotNull 'PGfloat8,+ "im" ::: 'NotNull 'PGfloat8]+instance ToPG db Complex where+ toPG = rowParam $ real `as` #re #. imaginary `as` #im+:}+-}+rowParam+ :: (PG x ~ 'PGcomposite row, SOP.All (OidOfField db) row)+ => EncodeParams db row x+ -- ^ use `(.#)` and `(#.)` to define a row parameter encoding+ -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding)+rowParam (enc :: EncodeParams db row x) x = do+ let+ compositeSize+ = int4_int32+ $ fromIntegral+ $ SOP.lengthSList+ $ SOP.Proxy @row+ each+ :: OidOfField db field+ => SOP.K (Maybe Encoding) field+ -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding+ each (SOP.K field :: SOP.K (Maybe Encoding) field) = do+ oid <- getOid <$> oidOfField @db @field+ return $ int4_word32 oid <> maybe null4 sized field+ fields <- runEncodeParams enc x+ compositePayload <- hcfoldMapM+ (SOP.Proxy @(OidOfField db)) each fields+ return $ compositeSize <> compositePayload++{- | Cons a row parameter encoding for `rowParam`. -}+(.#)+ :: forall db x0 fld ty x tys. (ToParam db ty x0, ty ~ NullPG x0)+ => Aliased ((->) x) (fld ::: x0) -- ^ head+ -> EncodeParams db tys x -- ^ tail+ -> EncodeParams db (fld ::: ty ': tys) x+(f `As` _) .# EncodeParams params = EncodeParams $ \x ->+ (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x+infixr 5 .#++{- | End a row parameter encoding for `rowParam`. -}+(#.)+ :: forall db x x0 fld0 ty0 x1 fld1 ty1+ . ( ToParam db ty0 x0+ , ty0 ~ NullPG x0+ , ToParam db ty1 x1+ , ty1 ~ NullPG x1+ )+ => Aliased ((->) x) (fld0 ::: x0) -- ^ second to last+ -> Aliased ((->) x) (fld1 ::: x1) -- ^ last+ -> EncodeParams db '[fld0 ::: ty0, fld1 ::: ty1] x+f #. g = f .# g .# nilParams+infixl 8 #.++instance (ToParam db ty x, ty ~ NullPG x)+ => IsLabel fld (EncodeParams db '[fld ::: ty] x) where+ fromLabel+ = EncodeParams+ $ fmap (\param -> SOP.K param :* Nil)+ . toParam @db @(NullPG x)++{- |+>>> import GHC.Generics as GHC+>>> :{+data L = L {frst :: Int16, scnd :: Char}+ deriving stock (GHC.Generic, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+data R = R {thrd :: Bool, frth :: Bool}+ deriving stock (GHC.Generic, Show)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+instance IsPG (L,R) where+ type PG (L,R) = 'PGcomposite '[+ "frst" ::: 'NotNull 'PGint2,+ "scnd" ::: 'NotNull ('PGchar 1),+ "thrd" ::: 'NotNull 'PGbool,+ "frth" ::: 'NotNull 'PGbool]+instance ToPG db (L,R) where+ toPG = rowParam $+ contramap fst genericRowParams+ `appendParams`+ contramap snd genericRowParams+:}+-}+genericRowParams+ :: forall db row x xs.+ ( SOP.IsRecord x xs+ , SOP.AllZip (ToField db) row xs+ )+ => EncodeParams db row x+genericRowParams+ = EncodeParams+ $ hctransverse (SOP.Proxy @(ToField db)) (toField @db)+ . SOP.toRecord++-- helper functions++getOid :: LibPQ.Oid -> Word32+getOid (LibPQ.Oid (CUInt oid)) = oid++encodeArray :: Int32 -> Bool -> LibPQ.Oid -> [Int32] -> Encoding -> Encoding+encodeArray ndim nulls oid dimensions payload = mconcat+ [ int4_int32 ndim+ , if nulls then true4 else false4+ , int4_word32 (getOid oid)+ , foldMap (\dimension -> int4_int32 dimension <> true4) dimensions+ , payload ]++dimArray+ :: Functor m+ => (forall b. (b -> a -> m b) -> b -> c -> m b)+ -> (a -> m Encoding) -> c -> m Encoding+dimArray folder elementArray = folder step mempty+ where+ step builder element = (builder <>) <$> elementArray element++null4, true4, false4 :: Encoding+null4 = int4_int32 (-1)+true4 = int4_word32 1+false4 = int4_word32 0++sized :: Encoding -> Encoding+sized bs = int4_int32 (fromIntegral (builderLength bs)) <> bs++hctransverse+ :: (SOP.AllZip c ys xs, Applicative m)+ => SOP.Proxy c+ -> (forall y x. c y x => f x -> m (g y))+ -> NP f xs -> m (NP g ys)+hctransverse c f = \case+ Nil -> pure Nil+ x :* xs -> (:*) <$> f x <*> hctransverse c f xs++hcfoldMapM+ :: (Monoid r, Applicative m, SOP.All c xs)+ => SOP.Proxy c+ -> (forall x. c x => f x -> m r)+ -> NP f xs -> m r+hcfoldMapM c f = \case+ Nil -> pure mempty+ x :* xs -> (<>) <$> f x <*> hcfoldMapM c f xs
+ src/Squeal/PostgreSQL/Session/Exception.hs view
@@ -0,0 +1,100 @@+{-|+Module: Squeal.PostgreSQL.Session.Exception+Description: exceptions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++exceptions+-}++{-# LANGUAGE+ OverloadedStrings+ , PatternSynonyms+#-}++module Squeal.PostgreSQL.Session.Exception+ ( SquealException (..)+ , pattern UniqueViolation+ , pattern CheckViolation+ , pattern SerializationFailure+ , pattern DeadlockDetected+ , SQLState (..)+ , LibPQ.ExecStatus (..)+ , catchSqueal+ , handleSqueal+ , trySqueal+ , throwSqueal+ ) where++import Control.Monad.Catch+import Data.ByteString (ByteString)+import Data.Text (Text)++import qualified Database.PostgreSQL.LibPQ as LibPQ++-- $setup+-- >>> import Squeal.PostgreSQL++-- | the state of LibPQ+data SQLState = SQLState+ { sqlExecStatus :: LibPQ.ExecStatus+ , sqlStateCode :: ByteString+ -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html+ , sqlErrorMessage :: ByteString+ } deriving (Eq, Show)++-- | `Exception`s that can be thrown by Squeal.+data SquealException+ = SQLException SQLState+ -- ^ SQL exception state+ | ConnectionException Text+ -- ^ `Database.PostgreSQL.LibPQ` function connection exception+ | DecodingException Text Text+ -- ^ decoding exception function and error message+ | ColumnsException Text LibPQ.Column+ -- ^ unexpected number of columns+ | RowsException Text LibPQ.Row LibPQ.Row+ -- ^ too few rows, expected at least and actual number of rows+ deriving (Eq, Show)+instance Exception SquealException++-- | A pattern for unique violation exceptions.+pattern UniqueViolation :: ByteString -> SquealException+pattern UniqueViolation msg =+ SQLException (SQLState LibPQ.FatalError "23505" msg)+-- | A pattern for check constraint violation exceptions.+pattern CheckViolation :: ByteString -> SquealException+pattern CheckViolation msg =+ SQLException (SQLState LibPQ.FatalError "23514" msg)+-- | A pattern for serialization failure exceptions.+pattern SerializationFailure :: ByteString -> SquealException+pattern SerializationFailure msg =+ SQLException (SQLState LibPQ.FatalError "40001" msg)+-- | A pattern for deadlock detection exceptions.+pattern DeadlockDetected :: ByteString -> SquealException+pattern DeadlockDetected msg =+ SQLException (SQLState LibPQ.FatalError "40P01" msg)++-- | Catch `SquealException`s.+catchSqueal+ :: MonadCatch m+ => m a+ -> (SquealException -> m a) -- ^ handler+ -> m a+catchSqueal = catch++-- | Handle `SquealException`s.+handleSqueal+ :: MonadCatch m+ => (SquealException -> m a) -- ^ handler+ -> m a -> m a+handleSqueal = handle++-- | `Either` return a `SquealException` or a result.+trySqueal :: MonadCatch m => m a -> m (Either SquealException a)+trySqueal = try++-- | Throw `SquealException`s.+throwSqueal :: MonadThrow m => SquealException -> m a+throwSqueal = throwM
+ src/Squeal/PostgreSQL/Session/Indexed.hs view
@@ -0,0 +1,126 @@+{-|+Module: Squeal.PostgreSQL.Session.Indexed+Description: indexed session monad+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++`Squeal.PostgreSQL.Indexed` provides an indexed monad transformer+class and a class extending it to run `Definition`s.+-}++{-# LANGUAGE+ DataKinds+ , DefaultSignatures+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , PolyKinds+ , MultiParamTypeClasses+ , QuantifiedConstraints+ , RankNTypes+ , TypeApplications+ , TypeFamilies+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Session.Indexed+ ( IndexedMonadTrans (..)+ , Indexed (..)+ , IndexedMonadTransPQ (..)+ , indexedDefine+ ) where++import Control.Category (Category (..))+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans+import Data.Function ((&))+import Prelude hiding (id, (.))++import Squeal.PostgreSQL.Definition++{- | An [Atkey indexed monad]+(https://bentnib.org/paramnotions-jfp.pdf)+is a `Functor` [enriched category]+(https://ncatlab.org/nlab/show/enriched+category).+An indexed monad transformer transforms a `Monad` into an indexed monad,+and is a monad transformer when its source and target are the same,+enabling use of standard @do@ notation for endo-index operations.+-}+class+ ( forall i j m. Monad m => Functor (t i j m)+ , forall i m. Monad m => Monad (t i i m)+ , forall i. MonadTrans (t i i)+ ) => IndexedMonadTrans t where++ {-# MINIMAL pqJoin | pqBind #-}++ -- | indexed analog of `<*>`+ pqAp+ :: Monad m+ => t i j m (x -> y)+ -> t j k m x+ -> t i k m y+ pqAp tf tx = pqBind (<$> tx) tf++ -- | indexed analog of `join`+ pqJoin+ :: Monad m+ => t i j m (t j k m y)+ -> t i k m y+ pqJoin t = t & pqBind id++ -- | indexed analog of `=<<`+ pqBind+ :: Monad m+ => (x -> t j k m y)+ -> t i j m x+ -> t i k m y+ pqBind f t = pqJoin (f <$> t)++ -- | indexed analog of flipped `>>`+ pqThen+ :: Monad m+ => t j k m y+ -> t i j m x+ -> t i k m y+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)++ -- | indexed analog of `<=<`+ pqAndThen+ :: Monad m+ => (y -> t j k m z)+ -> (x -> t i j m y)+ -> x -> t i k m z+ pqAndThen g f x = pqBind g (f x)++{- | `Indexed` reshuffles the type parameters of an `IndexedMonadTrans`,+exposing its `Category` instance.-}+newtype Indexed t m r i j = Indexed {runIndexed :: t i j m r}+instance+ ( IndexedMonadTrans t+ , Monad m+ , Monoid r+ ) => Category (Indexed t m r) where+ id = Indexed (pure mempty)+ Indexed g . Indexed f = Indexed $ pqAp (fmap (<>) f) g++{- | `IndexedMonadTransPQ` is a class for indexed monad transformers+that support running `Definition`s using `define` which acts functorially in effect.++* @define id = return ()@+* @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@+-}+class IndexedMonadTrans pq => IndexedMonadTransPQ pq where+ define :: MonadIO io => Definition db0 db1 -> pq db0 db1 io ()++{- | Run a pure SQL `Definition` functorially in effect++* @indexedDefine id = id@+* @indexedDefine (def1 >>> def2) = indexedDefine def1 >>> indexedDefine def2@+-}+indexedDefine+ :: (IndexedMonadTransPQ pq, MonadIO io)+ => Definition db0 db1 -> Indexed pq io () db0 db1+indexedDefine = Indexed . define
+ src/Squeal/PostgreSQL/Session/Migration.hs view
@@ -0,0 +1,456 @@+{-|+Module: Squeal.PostgreSQL.Session.Migration+Description: migrations+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++This module defines a `Migration` type to safely+change the schema of your database over time. Let's see an example!++First turn on some extensions.++>>> :set -XDataKinds -XOverloadedLabels+>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators++Next, let's define our `TableType`s.++>>> :{+type UsersTable =+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ ]+:}++>>> :{+type EmailsTable =+ '[ "pk_emails" ::: 'PrimaryKey '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"]+ ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "email" ::: 'NoDef :=> 'Null 'PGtext+ ]+:}++Now we can define some `Migration`s to make our tables.++`Migration`s are parameterized giving the option of a++* pure one-way `Migration` `Definition`+* impure one-way `Migration` @(@`Indexed` `PQ` `IO`@)@+* pure reversible `Migration` @(@`IsoQ` `Definition`@)@+* impure reversible `Migration` @(@`IsoQ` @(@`Indexed` `PQ` `IO`@)@@)@++For this example, we'll use pure reversible `Migration`s.++>>> :{+let+ makeUsers :: Migration (IsoQ Definition)+ '["public" ::: '[]]+ '["public" ::: '["users" ::: 'Table UsersTable]]+ makeUsers = Migration "make users table" IsoQ+ { up = createTable #users+ ( serial `as` #id :*+ notNullable text `as` #name )+ ( primaryKey #id `as` #pk_users )+ , down = dropTable #users+ }+:}++>>> :{+let+ makeEmails :: Migration (IsoQ Definition)+ '["public" ::: '["users" ::: 'Table UsersTable]]+ '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]+ makeEmails = Migration "make emails table" IsoQ+ { up = createTable #emails+ ( serial `as` #id :*+ notNullable int `as` #user_id :*+ nullable text `as` #email )+ ( primaryKey #id `as` #pk_emails :*+ foreignKey #user_id #users #id+ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_user_id )+ , down = dropTable #emails+ }+:}++Now that we have a couple migrations we can chain them together into a `Path`.++>>> let migrations = makeUsers :>> makeEmails :>> Done++Now run the migrations.++>>> import Control.Monad.IO.Class+>>> :{+withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;")+ -- suppress notices+ & pqThen (liftIO (putStrLn "Migrate"))+ & pqThen (migrateUp migrations)+ & pqThen (liftIO (putStrLn "Rollback"))+ & pqThen (migrateDown migrations)+:}+Migrate+Rollback++We can also create a simple executable using `mainMigrateIso`.++>>> let main = mainMigrateIso "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" migrations++>>> withArgs [] main+Invalid command: "". Use:+migrate to run all available migrations+rollback to rollback all available migrations+status to display migrations run and migrations left to run++>>> withArgs ["status"] main+Migrations already run:+ None+Migrations left to run:+ - make users table+ - make emails table++>>> withArgs ["migrate"] main+Migrations already run:+ - make users table+ - make emails table+Migrations left to run:+ None++>>> withArgs ["rollback"] main+Migrations already run:+ None+Migrations left to run:+ - make users table+ - make emails table++In addition to enabling `Migration`s using pure SQL `Definition`s for+the `up` and `down` migrations, you can also perform impure `IO` actions+by using a `Migration`s over the `Indexed` `PQ` `IO` category.+-}++{-# LANGUAGE+ DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes+ , TypeApplications+ , TypeOperators+#-}++module Squeal.PostgreSQL.Session.Migration+ ( -- * Migration+ Migration (..)+ , Migratory (..)+ , migrate+ , migrateUp+ , migrateDown+ , MigrationsTable+ -- * Executable+ , mainMigrate+ , mainMigrateIso+ -- * Re-export+ , IsoQ (..)+ ) where++import Control.Category+import Control.Category.Free+import Control.Monad+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import Data.Foldable (traverse_)+import Data.Function ((&))+import Data.List ((\\))+import Data.Quiver+import Data.Quiver.Functor+import Data.Text (Text)+import Data.Time (UTCTime)+import Prelude hiding ((.), id)+import System.Environment++import qualified Data.Text.IO as Text (putStrLn)+import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Definition+import Squeal.PostgreSQL.Definition.Constraint+import Squeal.PostgreSQL.Definition.Table+import Squeal.PostgreSQL.Expression.Comparison+import Squeal.PostgreSQL.Expression.Default+import Squeal.PostgreSQL.Expression.Parameter+import Squeal.PostgreSQL.Expression.Time+import Squeal.PostgreSQL.Expression.Type+import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Manipulation.Delete+import Squeal.PostgreSQL.Manipulation.Insert+import Squeal.PostgreSQL.Session+import Squeal.PostgreSQL.Session.Decode+import Squeal.PostgreSQL.Session.Encode+import Squeal.PostgreSQL.Session.Indexed+import Squeal.PostgreSQL.Session.Monad+import Squeal.PostgreSQL.Session.Result+import Squeal.PostgreSQL.Session.Statement+import Squeal.PostgreSQL.Session.Transaction.Unsafe+import Squeal.PostgreSQL.Query.From+import Squeal.PostgreSQL.Query.Select+import Squeal.PostgreSQL.Query.Table+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Type.Schema++-- | A `Migration` consists of a name and a migration definition.+data Migration def db0 db1 = Migration+ { migrationName :: Text -- ^ The name of a `Migration`.+ -- Each `migrationName` should be unique.+ , migrationDef :: def db0 db1 -- ^ The migration of a `Migration`.+ } deriving (GHC.Generic)+instance QFunctor Migration where+ qmap f (Migration n i) = Migration n (f i)++{- |+A `Migratory` `Category` can run or+possibly rewind a `Path` of `Migration`s.+-}+class (Category def, Category run) => Migratory def run | def -> run where+ {- | Run a `Path` of `Migration`s.-}+ runMigrations :: Path (Migration def) db0 db1 -> run db0 db1+-- | impure migrations+instance Migratory (Indexed PQ IO ()) (Indexed PQ IO ()) where+ runMigrations path = Indexed . unsafePQ . transactionally_ $ do+ define createMigrations+ qtoMonoid upMigration path+ where+ upMigration step = do+ executed <- do+ result <- executeParams selectMigration (migrationName step)+ ntuples (result :: Result UTCTime)+ unless (executed == 1) $ do+ _ <- unsafePQ . runIndexed $ migrationDef step+ executeParams_ insertMigration (migrationName step)+-- | pure migrations+instance Migratory Definition (Indexed PQ IO ()) where+ runMigrations = runMigrations . qmap (qmap ixDefine)+-- | impure rewinds+instance Migratory (OpQ (Indexed PQ IO ())) (OpQ (Indexed PQ IO ())) where+ runMigrations path = OpQ . Indexed . unsafePQ . transactionally_ $ do+ define createMigrations+ qtoMonoid @FoldPath downMigration (reversePath path)+ where+ downMigration (OpQ step) = do+ executed <- do+ result <- executeParams selectMigration (migrationName step)+ ntuples (result :: Result UTCTime)+ unless (executed == 0) $ do+ _ <- unsafePQ . runIndexed . getOpQ $ migrationDef step+ executeParams_ deleteMigration (migrationName step)+-- | pure rewinds+instance Migratory (OpQ Definition) (OpQ (Indexed PQ IO ())) where+ runMigrations = runMigrations . qmap (qmap (qmap ixDefine))+-- | impure rewindable migrations+instance Migratory+ (IsoQ (Indexed PQ IO ()))+ (IsoQ (Indexed PQ IO ())) where+ runMigrations path = IsoQ+ (runMigrations (qmap (qmap up) path))+ (getOpQ (runMigrations (qmap (qmap (OpQ . down)) path)))+-- | pure rewindable migrations+instance Migratory (IsoQ Definition) (IsoQ (Indexed PQ IO ())) where+ runMigrations = runMigrations . qmap (qmap (qmap ixDefine))++unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK++-- | Run migrations.+migrate+ :: Migratory def (Indexed PQ IO ())+ => Path (Migration def) db0 db1+ -> PQ db0 db1 IO ()+migrate = runIndexed . runMigrations++-- | Run rewindable migrations.+migrateUp+ :: Migratory def (IsoQ (Indexed PQ IO ()))+ => Path (Migration def) db0 db1+ -> PQ db0 db1 IO ()+migrateUp = runIndexed . up . runMigrations++-- | Rewind migrations.+migrateDown+ :: Migratory def (IsoQ (Indexed PQ IO ()))+ => Path (Migration def) db0 db1+ -> PQ db1 db0 IO ()+migrateDown = runIndexed . down . runMigrations++ixDefine :: Definition db0 db1 -> Indexed PQ IO () db0 db1+ixDefine = indexedDefine++-- | The `TableType` for a Squeal migration.+type MigrationsTable =+ '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>+ '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext+ , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz+ ]++data MigrationRow =+ MigrationRow { name :: Text+ , executed_at :: UTCTime }+ deriving (GHC.Generic, Show)++instance SOP.Generic MigrationRow+instance SOP.HasDatatypeInfo MigrationRow++type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]+type MigrationsSchemas = Public MigrationsSchema++-- | Creates a `MigrationsTable` if it does not already exist.+createMigrations :: Definition MigrationsSchemas MigrationsSchemas+createMigrations =+ createTableIfNotExists #schema_migrations+ ( (text & notNullable) `as` #name :*+ (timestampWithTimeZone & notNullable & default_ currentTimestamp)+ `as` #executed_at )+ ( unique #name `as` #migrations_unique_name )++-- | Inserts a `Migration` into the `MigrationsTable`, returning+-- the time at which it was inserted.+insertMigration :: Statement MigrationsSchemas Text ()+insertMigration = Manipulation aParam genericRow $+ insertInto_ #schema_migrations $+ Values_ (Set (param @1) `as` #name :* Default `as` #executed_at)++-- | Deletes a `Migration` from the `MigrationsTable`, returning+-- the time at which it was inserted.+deleteMigration :: Statement MigrationsSchemas Text ()+deleteMigration = Manipulation aParam genericRow $+ deleteFrom_ #schema_migrations (#name .== param @1)++-- | Selects a `Migration` from the `MigrationsTable`, returning+-- the time at which it was inserted.+selectMigration :: Statement MigrationsSchemas Text UTCTime+selectMigration = Query aParam #executed_at $+ select_ #executed_at+ $ from (table (#schema_migrations))+ & where_ (#name .== param @1)++selectMigrations :: Statement MigrationsSchemas () MigrationRow+selectMigrations = query $ select Star (from (table #schema_migrations))++{- | `mainMigrate` creates a simple executable+from a connection string and a `Path` of `Migration`s. -}+mainMigrate+ :: Migratory p (Indexed PQ IO ())+ => ByteString+ -- ^ connection string+ -> Path (Migration p) db0 db1+ -- ^ migrations+ -> IO ()+mainMigrate connectTo migrations = do+ command <- getArgs+ performCommand command++ where++ performCommand :: [String] -> IO ()+ performCommand = \case+ ["status"] -> withConnection connectTo $+ suppressNotices >> migrateStatus+ ["migrate"] -> withConnection connectTo $+ suppressNotices+ & pqThen (runIndexed (runMigrations migrations))+ & pqThen migrateStatus+ args -> displayUsage args++ migrateStatus :: PQ schema schema IO ()+ migrateStatus = unsafePQ $ do+ runNames <- getRunMigrationNames+ let names = qtoList migrationName migrations+ unrunNames = names \\ runNames+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames++ suppressNotices :: PQ schema schema IO ()+ suppressNotices = manipulate_ $+ UnsafeManipulation "SET client_min_messages TO WARNING;"++ displayUsage :: [String] -> IO ()+ displayUsage args = do+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"+ putStrLn "migrate to run all available migrations"+ putStrLn "rollback to rollback all available migrations"++{- | `mainMigrateIso` creates a simple executable+from a connection string and a `Path` of `Migration` `IsoQ`s. -}+mainMigrateIso+ :: Migratory (IsoQ def) (IsoQ (Indexed PQ IO ()))+ => ByteString+ -- ^ connection string+ -> Path (Migration (IsoQ def)) db0 db1+ -- ^ migrations+ -> IO ()+mainMigrateIso connectTo migrations = performCommand =<< getArgs++ where++ performCommand :: [String] -> IO ()+ performCommand = \case+ ["status"] -> withConnection connectTo $+ suppressNotices >> migrateStatus+ ["migrate"] -> withConnection connectTo $+ suppressNotices+ & pqThen (migrateUp migrations)+ & pqThen migrateStatus+ ["rollback"] -> withConnection connectTo $+ suppressNotices+ & pqThen (migrateDown migrations)+ & pqThen migrateStatus+ args -> displayUsage args++ migrateStatus :: PQ schema schema IO ()+ migrateStatus = unsafePQ $ do+ runNames <- getRunMigrationNames+ let names = qtoList migrationName migrations+ unrunNames = names \\ runNames+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames++ suppressNotices :: PQ schema schema IO ()+ suppressNotices = manipulate_ $+ UnsafeManipulation "SET client_min_messages TO WARNING;"++ displayUsage :: [String] -> IO ()+ displayUsage args = do+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"+ putStrLn "migrate to run all available migrations"+ putStrLn "rollback to rollback all available migrations"+ putStrLn "status to display migrations run and migrations left to run"++getRunMigrationNames :: PQ db0 db0 IO [Text]+getRunMigrationNames =+ fmap name <$>+ (unsafePQ (define createMigrations+ & pqThen (execute selectMigrations)) >>= getRows)++displayListOfNames :: [Text] -> IO ()+displayListOfNames [] = Text.putStrLn " None"+displayListOfNames xs =+ let singleName n = Text.putStrLn $ " - " <> n+ in traverse_ singleName xs++displayUnrunned :: [Text] -> IO ()+displayUnrunned unrunned =+ Text.putStrLn "Migrations left to run:"+ >> displayListOfNames unrunned++displayRunned :: [Text] -> IO ()+displayRunned runned =+ Text.putStrLn "Migrations already run:"+ >> displayListOfNames runned
+ src/Squeal/PostgreSQL/Session/Monad.hs view
@@ -0,0 +1,765 @@+{-|+Module: Squeal.PostgreSQL.Session.Monad+Description: session monad+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Run `Squeal.PostgreSQL.Session.Statement`s in the mtl-style+typeclass `MonadPQ`.+-}+{-# LANGUAGE+ DataKinds+ , DefaultSignatures+ , DeriveFunctor+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , MultiParamTypeClasses+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Session.Monad+ ( -- * MonadPQ+ MonadPQ (..)+ -- * Manipulate+ , manipulateParams+ , manipulateParams_+ , manipulate+ , manipulate_+ -- * Run Query+ , runQueryParams+ , runQuery+ -- * Prepared+ , executePrepared+ , executePrepared_+ , traversePrepared+ , forPrepared+ , traversePrepared_+ , forPrepared_+ , preparedFor+ ) where++import Control.Category (Category (..))+import Control.Monad+import Control.Monad.Morph+import Data.Foldable+import Data.Profunctor.Traversing+import Data.Traversable+import Prelude hiding (id, (.))++import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Session.Decode+import Squeal.PostgreSQL.Session.Encode+import Squeal.PostgreSQL.Session.Result+import Squeal.PostgreSQL.Session.Statement+import Squeal.PostgreSQL.Query++-- For `MonadPQ` transformer instances+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+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++-- $setup+-- >>> import Squeal.PostgreSQL++{- | `MonadPQ` is an @mtl@ style constraint, similar to+`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ`+to run `Statement`s.+-}+class Monad pq => MonadPQ db pq | pq -> db where++ {- |+ `executeParams` runs a `Statement` which takes out-of-line+ `Squeal.PostgreSQL.Expression.Parameter.parameter`s.++ >>> import Data.Int (Int32, Int64)+ >>> import Data.Monoid (Sum(Sum))+ >>> :{+ let+ sumOf :: Statement db (Int32, Int32) (Sum Int32)+ sumOf = query $ values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- executeParams sumOf (2,2)+ firstRow result+ :}+ Just (Sum {getSum = 4})+ -}+ executeParams+ :: Statement db x y+ -- ^ query or manipulation+ -> x+ -- ^ parameters+ -> pq (Result y)+ default executeParams+ :: (MonadTrans t, MonadPQ db m, pq ~ t m)+ => Statement db x y+ -- ^ query or manipulation+ -> x+ -- ^ parameters+ -> pq (Result y)+ executeParams statement params = lift $ executeParams statement params++ {- |+ `executeParams_` runs a returning-free `Statement`.++ >>> type Column = 'NoDef :=> 'NotNull 'PGint4+ >>> type Columns = '["col1" ::: Column, "col2" ::: Column]+ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+ >>> type DB = Public Schema+ >>> import Data.Int(Int32)+ >>> :{+ let+ insertion :: Statement DB (Int32, Int32) ()+ insertion = manipulation $ insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (executeParams_ insertion (2,2))+ & pqThen (define teardown)+ :}+ -}+ executeParams_+ :: Statement db x ()+ -- ^ query or manipulation+ -> x+ -- ^ parameters+ -> pq ()+ executeParams_ statement params = void $ executeParams statement params++ {- | `execute` runs a parameter-free `Statement`.++ >>> import Data.Int(Int32)+ >>> :{+ let+ two :: Expr ('NotNull 'PGint4)+ two = 2+ twoPlusTwo :: Statement db () (Only Int32)+ twoPlusTwo = query $ values_ $ (two + two) `as` #fromOnly+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- execute twoPlusTwo+ firstRow result+ :}+ Just (Only {fromOnly = 4})+ -}+ execute+ :: Statement db () y+ -- ^ query or manipulation+ -> pq (Result y)+ execute statement = executeParams statement ()++ {- | `execute_` runs a parameter-free, returning-free `Statement`.++ >>> :{+ let+ silence :: Statement db () ()+ silence = manipulation $+ UnsafeManipulation "Set client_min_messages TO WARNING"+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ execute_ silence+ :}+ -}+ execute_+ :: Statement db () ()+ -- ^ query or manipulation+ -> pq ()+ execute_ = void . execute++ {- |+ `prepare` creates a `Prepared` statement. When `prepare` is executed,+ the specified `Statement` is parsed, analyzed, and rewritten.++ >>> import Data.Int (Int32, Int64)+ >>> import Data.Monoid (Sum(Sum))+ >>> :{+ let+ sumOf :: Statement db (Int32, Int32) (Sum Int32)+ sumOf = query $ values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ prepared <- prepare sumOf+ result <- runPrepared prepared (2,2)+ deallocate prepared+ firstRow result+ :}+ Just (Sum {getSum = 4})+ -}+ prepare+ :: Statement db x y+ -- ^ query or manipulation+ -> pq (Prepared pq x (Result y))+ default prepare+ :: (MonadTrans t, MonadPQ db m, pq ~ t m)+ => Statement db x y+ -- ^ query or manipulation+ -> pq (Prepared pq x (Result y))+ prepare statement = do+ prepared <- lift $ prepare statement+ return $ Prepared+ (lift . runPrepared prepared)+ (lift (deallocate prepared))++ {- |+ `prepare_` creates a `Prepared` statement. When `prepare_` is executed,+ the specified `Statement` is parsed, analyzed, and rewritten.++ >>> type Column = 'NoDef :=> 'NotNull 'PGint4+ >>> type Columns = '["col1" ::: Column, "col2" ::: Column]+ >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+ >>> type DB = Public Schema+ >>> import Data.Int(Int32)+ >>> :{+ let+ insertion :: Statement DB (Int32, Int32) ()+ insertion = manipulation $ insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ session :: PQ DB DB IO ()+ session = do+ prepared <- prepare_ insertion+ runPrepared prepared (2,2)+ deallocate prepared+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+ in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen session+ & pqThen (define teardown)+ :}+ -}+ prepare_+ :: Statement db x ()+ -- ^ query or manipulation+ -> pq (Prepared pq x ())+ prepare_ = fmap void . prepare++{- |+* `prepare` a statement+* transforming its inputs and outputs with an optic,+ run the `Prepared` statement+* deallocate the `Prepared` statement++>>> :type preparedFor traverse'+preparedFor traverse'+ :: (MonadPQ db pq, Traversable f) =>+ Statement db a b -> f a -> pq (f (Result b))+-}+preparedFor+ :: MonadPQ db pq+ => (Prepared pq a (Result b) -> Prepared pq s t)+ -- ^ transform the input and output+ -> Statement db a b -- ^ query or manipulation+ -> s -> pq t+preparedFor optic statement x' = do+ prepared <- prepare statement+ y' <- runPrepared (optic prepared) x'+ deallocate prepared+ return y'++{- |+`executePrepared` runs a `Statement` on a `Traversable`+container by first preparing the statement, then running the prepared+statement on each element.++>>> import Data.Int (Int32, Int64)+>>> import Data.Monoid (Sum(Sum))+>>> :{+let+ sumOf :: Statement db (Int32, Int32) (Sum Int32)+ sumOf = query $ values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ results <- executePrepared sumOf [(2,2),(3,3),(4,4)]+ traverse firstRow results+:}+[Just (Sum {getSum = 4}),Just (Sum {getSum = 6}),Just (Sum {getSum = 8})]+-}+executePrepared+ :: (MonadPQ db pq, Traversable list)+ => Statement db x y+ -- ^ query or manipulation+ -> list x+ -- ^ list of parameters+ -> pq (list (Result y))+executePrepared = preparedFor traverse'++{- |+`executePrepared_` runs a returning-free `Statement` on a `Foldable`+container by first preparing the statement, then running the prepared+statement on each element.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Statement DB (Int32, Int32) ()+ insertion = manipulation $ insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (executePrepared_ insertion [(2,2),(3,3),(4,4)])+ & pqThen (define teardown)+:}+-}+executePrepared_+ :: (MonadPQ db pq, Foldable list)+ => Statement db x ()+ -- ^ query or manipulation+ -> list x+ -- ^ list of parameters+ -> pq ()+executePrepared_ = preparedFor (wander traverse_)++{- |+`manipulateParams` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32)+ insertAdd = insertInto #tab + ( Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ ) OnConflictDoRaise+ ( Returning_ ((#col1 + #col2) `as` #fromOnly) )+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ result <- manipulateParams insertAdd (2::Int32,2::Int32)+ Just (Only answer) <- firstRow result+ liftIO $ print (answer :: Int32)+ )+ & pqThen (define teardown)+:}+4+-}+manipulateParams ::+ ( MonadPQ db pq+ , GenericParams db params x xs+ , GenericRow row y ys+ ) => Manipulation '[] db params row+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends+ -> x -> pq (Result y)+manipulateParams = executeParams . manipulation++{- |+`manipulateParams_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`,+for a returning-free statement.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Manipulation_ DB (Int32, Int32) ()+ insertion = insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (manipulateParams_ insertion (2::Int32,2::Int32))+ & pqThen (define teardown)+:}+-}+manipulateParams_ ::+ ( MonadPQ db pq+ , GenericParams db params x xs+ ) => Manipulation '[] db params '[]+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update_`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends+ -> x -> pq ()+manipulateParams_ = executeParams_ . manipulation++{- |+`manipulate` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`,+for a parameter-free statement.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertTwoPlusTwo :: Manipulation_ DB () (Only Int32)+ insertTwoPlusTwo = insertInto #tab + (Values_ $ Set 2 `as` #col1 :* Set 2 `as` #col2)+ OnConflictDoRaise+ (Returning_ ((#col1 + #col2) `as` #fromOnly))+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ result <- manipulate insertTwoPlusTwo+ Just (Only answer) <- firstRow result+ liftIO $ print (answer :: Int32)+ )+ & pqThen (define teardown)+:}+4+-}+manipulate+ :: (MonadPQ db pq, GenericRow row y ys)+ => Manipulation '[] db '[] row+ -> pq (Result y)+manipulate = execute . manipulation++{- |+`manipulate_` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`,+for a returning-free, parameter-free statement.++>>> :{+let+ silence :: Manipulation_ db () ()+ silence = UnsafeManipulation "Set client_min_messages TO WARNING"+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ manipulate_ silence+:}+-}+manipulate_+ :: MonadPQ db pq+ => Manipulation '[] db '[] '[]+ -> pq ()+manipulate_ = execute_ . manipulation++{- |+`runQueryParams` runs a `Squeal.PostgreSQL.Query.Query`.++>>> import Data.Int (Int32, Int64)+>>> import Control.Monad.IO.Class+>>> import Data.Monoid (Sum(Sum))+>>> :{+let+ sumOf :: Query_ db (Int32, Int32) (Sum Int32)+ sumOf = values_ $+ ( param @1 @('NotNull 'PGint4) ++ param @2 @('NotNull 'PGint4)+ ) `as` #getSum+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- runQueryParams sumOf (2::Int32,2::Int32)+ Just (Sum four) <- firstRow result+ liftIO $ print (four :: Int32)+:}+4+-}+runQueryParams ::+ ( MonadPQ db pq+ , GenericParams db params x xs+ , GenericRow row y ys+ ) => Query '[] '[] db params row+ -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends+ -> x -> pq (Result y)+runQueryParams = executeParams . query++{- |+`runQuery` runs a `Squeal.PostgreSQL.Query.Query`,+for a parameter-free statement.++>>> import Data.Int (Int32, Int64)+>>> import Control.Monad.IO.Class+>>> import Data.Monoid (Sum(Sum))+>>> :{+let+ twoPlusTwo :: Query_ db () (Sum Int32)+ twoPlusTwo = values_ $ (2 + 2) `as` #getSum+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $ do+ result <- runQuery twoPlusTwo+ Just (Sum four) <- firstRow result+ liftIO $ print (four :: Int32)+:}+4+-}+runQuery+ :: (MonadPQ db pq, GenericRow row y ys)+ => Query '[] '[] db '[] row+ -- ^ `Squeal.PostgreSQL.Query.Select.select` and friends+ -> pq (Result y)+runQuery = execute . query++{- |+`traversePrepared` runs a `Squeal.PostgreSQL.Manipulation.Manipulation`+on a `Traversable` container by first preparing the statement,+then running the prepared statement on each element.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32)+ insertAdd = insertInto #tab + ( Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ ) OnConflictDoRaise+ ( Returning_ ((#col1 + #col2) `as` #fromOnly) )+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ results <- traversePrepared insertAdd [(2::Int32,2::Int32),(3,3),(4,4)]+ answers <- traverse firstRow results+ liftIO $ print [answer :: Int32 | Just (Only answer) <- answers]+ )+ & pqThen (define teardown)+:}+[4,6,8]+-}+traversePrepared+ :: ( MonadPQ db pq+ , GenericParams db params x xs+ , GenericRow row y ys+ , Traversable list )+ => Manipulation '[] db params row+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends+ -> list x -> pq (list (Result y))+traversePrepared = executePrepared . manipulation++{- |+`forPrepared` is a flipped `traversePrepared`++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Control.Monad.IO.Class+>>> import Data.Int(Int32)+>>> :{+let+ insertAdd :: Manipulation_ DB (Int32, Int32) (Only Int32)+ insertAdd = insertInto #tab + ( Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ ) OnConflictDoRaise+ ( Returning_ ((#col1 + #col2) `as` #fromOnly) )+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen+ ( do+ results <- forPrepared [(2::Int32,2::Int32),(3,3),(4,4)] insertAdd+ answers <- traverse firstRow results+ liftIO $ print [answer :: Int32 | Just (Only answer) <- answers]+ )+ & pqThen (define teardown)+:}+[4,6,8]+-}+forPrepared+ :: ( MonadPQ db pq+ , GenericParams db params x xs+ , GenericRow row y ys+ , Traversable list )+ => list x+ -> Manipulation '[] db params row+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, and friends+ -> pq (list (Result y))+forPrepared = flip traversePrepared++{- |+`traversePrepared_` runs a returning-free+`Squeal.PostgreSQL.Manipulation.Manipulation` on a `Foldable`+container by first preparing the statement, then running the prepared+statement on each element.++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Manipulation_ DB (Int32, Int32) ()+ insertion = insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (traversePrepared_ insertion [(2::Int32,2::Int32),(3,3),(4,4)])+ & pqThen (define teardown)+:}+-}+traversePrepared_+ :: ( MonadPQ db pq+ , GenericParams db params x xs+ , Foldable list )+ => Manipulation '[] db params '[]+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update_`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends+ -> list x -> pq ()+traversePrepared_ = executePrepared_ . manipulation++{- |+`forPrepared_` is a flipped `traversePrepared_`++>>> type Column = 'NoDef :=> 'NotNull 'PGint4+>>> type Columns = '["col1" ::: Column, "col2" ::: Column]+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]+>>> type DB = Public Schema+>>> import Data.Int(Int32)+>>> :{+let+ insertion :: Manipulation_ DB (Int32, Int32) ()+ insertion = insertInto_ #tab $ Values_ $+ Set (param @1 @('NotNull 'PGint4)) `as` #col1 :*+ Set (param @2 @('NotNull 'PGint4)) `as` #col2+ setup :: Definition (Public '[]) DB+ setup = createTable #tab+ ( notNullable int4 `as` #col1 :*+ notNullable int4 `as` #col2+ ) Nil+ teardown :: Definition DB (Public '[])+ teardown = dropTable #tab+in+ withConnection "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" $+ define setup+ & pqThen (forPrepared_ [(2::Int32,2::Int32),(3,3),(4,4)] insertion)+ & pqThen (define teardown)+:}+-}+forPrepared_+ :: ( MonadPQ db pq+ , GenericParams db params x xs+ , Foldable list )+ => list x+ -> Manipulation '[] db params '[]+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto_`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update_`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom_`, and friends+ -> pq ()+forPrepared_ = flip traversePrepared_++instance MonadPQ db m => MonadPQ db (IdentityT m)+instance MonadPQ db m => MonadPQ db (ReaderT r m)+instance MonadPQ db m => MonadPQ db (Strict.StateT s m)+instance MonadPQ db m => MonadPQ db (Lazy.StateT s m)+instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.WriterT w m)+instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.WriterT w m)+instance MonadPQ db m => MonadPQ db (MaybeT m)+instance MonadPQ db m => MonadPQ db (ExceptT e m)+instance (Monoid w, MonadPQ db m) => MonadPQ db (Strict.RWST r w s m)+instance (Monoid w, MonadPQ db m) => MonadPQ db (Lazy.RWST r w s m)+instance MonadPQ db m => MonadPQ db (ContT r m)
+ src/Squeal/PostgreSQL/Session/Oid.hs view
@@ -0,0 +1,234 @@+{-|+Module: Squeal.PostgreSQL.Session.Oid+Description: object identifiers+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Object identifiers are used internally by PostgreSQL as+primary keys. They are needed to correctly encode+statement parameters.+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , DataKinds+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Session.Oid+ ( -- * Oids+ LibPQ.Oid+ , OidOf (..)+ , OidOfArray (..)+ , OidOfNull (..)+ , OidOfField (..)+ ) where++import Control.Monad (when)+import Control.Monad.Catch (throwM)+import Control.Monad.Reader+import Data.String+import GHC.TypeLits+import PostgreSQL.Binary.Decoding (valueParser, int)++import qualified Data.ByteString as ByteString+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Session.Exception+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL++-- | The `LibPQ.Oid` of a `PGType`+--+-- >>> :set -XTypeApplications+-- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"+-- >>> runReaderT (oidOf @'[] @'PGbool) conn+-- Oid 16+--+-- >>> finish conn+class OidOf (db :: SchemasType) (pg :: PGType) where+ oidOf :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid+-- | The `LibPQ.Oid` of an array+class OidOfArray (db :: SchemasType) (pg :: PGType) where+ oidOfArray :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid+instance OidOfArray db pg => OidOf db ('PGvararray (null pg)) where+ oidOf = oidOfArray @db @pg+instance OidOfArray db pg => OidOf db ('PGfixarray dims (null pg)) where+ oidOf = oidOfArray @db @pg+-- | The `LibPQ.Oid` of a `NullType`+class OidOfNull (db :: SchemasType) (ty :: NullType) where+ oidOfNull :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid+instance OidOf db pg => OidOfNull db (null pg) where+ oidOfNull = oidOf @db @pg+-- | The `LibPQ.Oid` of a field+class OidOfField (db :: SchemasType) (field :: (Symbol, NullType)) where+ oidOfField :: ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid+instance OidOfNull db ty => OidOfField db (fld ::: ty) where+ oidOfField = oidOfNull @db @ty++instance OidOf db 'PGbool where oidOf = pure $ LibPQ.Oid 16+instance OidOfArray db 'PGbool where oidOfArray = pure $ LibPQ.Oid 1000+instance OidOf db 'PGint2 where oidOf = pure $ LibPQ.Oid 21+instance OidOfArray db 'PGint2 where oidOfArray = pure $ LibPQ.Oid 1005+instance OidOf db 'PGint4 where oidOf = pure $ LibPQ.Oid 23+instance OidOfArray db 'PGint4 where oidOfArray = pure $ LibPQ.Oid 1007+instance OidOf db 'PGint8 where oidOf = pure $ LibPQ.Oid 20+instance OidOfArray db 'PGint8 where oidOfArray = pure $ LibPQ.Oid 1016+instance OidOf db 'PGnumeric where oidOf = pure $ LibPQ.Oid 1700+instance OidOfArray db 'PGnumeric where oidOfArray = pure $ LibPQ.Oid 1231+instance OidOf db 'PGfloat4 where oidOf = pure $ LibPQ.Oid 700+instance OidOfArray db 'PGfloat4 where oidOfArray = pure $ LibPQ.Oid 1021+instance OidOf db 'PGfloat8 where oidOf = pure $ LibPQ.Oid 701+instance OidOfArray db 'PGfloat8 where oidOfArray = pure $ LibPQ.Oid 1022+instance OidOf db 'PGmoney where oidOf = pure $ LibPQ.Oid 790+instance OidOfArray db 'PGmoney where oidOfArray = pure $ LibPQ.Oid 791+instance OidOf db ('PGchar n) where oidOf = pure $ LibPQ.Oid 18+instance OidOfArray db ('PGchar n) where oidOfArray = pure $ LibPQ.Oid 1002+instance OidOf db ('PGvarchar n) where oidOf = pure $ LibPQ.Oid 1043+instance OidOfArray db ('PGvarchar n) where oidOfArray = pure $ LibPQ.Oid 1015+instance OidOf db 'PGtext where oidOf = pure $ LibPQ.Oid 25+instance OidOfArray db 'PGtext where oidOfArray = pure $ LibPQ.Oid 1009+instance OidOf db 'PGbytea where oidOf = pure $ LibPQ.Oid 17+instance OidOfArray db 'PGbytea where oidOfArray = pure $ LibPQ.Oid 1001+instance OidOf db 'PGtimestamp where oidOf = pure $ LibPQ.Oid 1114+instance OidOfArray db 'PGtimestamp where oidOfArray = pure $ LibPQ.Oid 1115+instance OidOf db 'PGtimestamptz where oidOf = pure $ LibPQ.Oid 1184+instance OidOfArray db 'PGtimestamptz where oidOfArray = pure $ LibPQ.Oid 1185+instance OidOf db 'PGdate where oidOf = pure $ LibPQ.Oid 1082+instance OidOfArray db 'PGdate where oidOfArray = pure $ LibPQ.Oid 1182+instance OidOf db 'PGtime where oidOf = pure $ LibPQ.Oid 1083+instance OidOfArray db 'PGtime where oidOfArray = pure $ LibPQ.Oid 1183+instance OidOf db 'PGtimetz where oidOf = pure $ LibPQ.Oid 1266+instance OidOfArray db 'PGtimetz where oidOfArray = pure $ LibPQ.Oid 1270+instance OidOf db 'PGinterval where oidOf = pure $ LibPQ.Oid 1186+instance OidOfArray db 'PGinterval where oidOfArray = pure $ LibPQ.Oid 1187+instance OidOf db 'PGuuid where oidOf = pure $ LibPQ.Oid 2950+instance OidOfArray db 'PGuuid where oidOfArray = pure $ LibPQ.Oid 2951+instance OidOf db 'PGinet where oidOf = pure $ LibPQ.Oid 869+instance OidOfArray db 'PGinet where oidOfArray = pure $ LibPQ.Oid 1041+instance OidOf db 'PGjson where oidOf = pure $ LibPQ.Oid 114+instance OidOfArray db 'PGjson where oidOfArray = pure $ LibPQ.Oid 199+instance OidOf db 'PGjsonb where oidOf = pure $ LibPQ.Oid 3802+instance OidOfArray db 'PGjsonb where oidOfArray = pure $ LibPQ.Oid 3807+instance OidOf db 'PGtsvector where oidOf = pure $ LibPQ.Oid 3614+instance OidOfArray db 'PGtsvector where oidOfArray = pure $ LibPQ.Oid 3643+instance OidOf db 'PGtsquery where oidOf = pure $ LibPQ.Oid 3615+instance OidOfArray db 'PGtsquery where oidOfArray = pure $ LibPQ.Oid 3645+instance OidOf db 'PGoid where oidOf = pure $ LibPQ.Oid 26+instance OidOfArray db 'PGoid where oidOfArray = pure $ LibPQ.Oid 1028+instance OidOf db ('PGrange 'PGint4) where oidOf = pure $ LibPQ.Oid 3904+instance OidOfArray db ('PGrange 'PGint4) where oidOfArray = pure $ LibPQ.Oid 3905+instance OidOf db ('PGrange 'PGint8) where oidOf = pure $ LibPQ.Oid 3926+instance OidOfArray db ('PGrange 'PGint8) where oidOfArray = pure $ LibPQ.Oid 3927+instance OidOf db ('PGrange 'PGnumeric) where oidOf = pure $ LibPQ.Oid 3906+instance OidOfArray db ('PGrange 'PGnumeric) where oidOfArray = pure $ LibPQ.Oid 3907+instance OidOf db ('PGrange 'PGtimestamp) where oidOf = pure $ LibPQ.Oid 3908+instance OidOfArray db ('PGrange 'PGtimestamp) where oidOfArray = pure $ LibPQ.Oid 3909+instance OidOf db ('PGrange 'PGtimestamptz) where oidOf = pure $ LibPQ.Oid 3910+instance OidOfArray db ('PGrange 'PGtimestamptz) where oidOfArray = pure $ LibPQ.Oid 3911+instance OidOf db ('PGrange 'PGdate) where oidOf = pure $ LibPQ.Oid 3912+instance OidOfArray db ('PGrange 'PGdate) where oidOfArray = pure $ LibPQ.Oid 3913+instance+ ( KnownSymbol sch+ , KnownSymbol td+ , rels ~ DbRelations db+ , FindQualified "no relation found with row:" rels row ~ '(sch,td)+ ) => OidOf db ('PGcomposite row) where+ oidOf = oidOfTypedef @sch @td+instance+ ( KnownSymbol sch+ , KnownSymbol td+ , rels ~ DbRelations db+ , FindQualified "no relation found with row:" rels row ~ '(sch,td)+ ) => OidOfArray db ('PGcomposite row) where+ oidOfArray = oidOfArrayTypedef @sch @td+instance+ ( enums ~ DbEnums db+ , FindQualified "no enum found with labels:" enums labels ~ '(sch,td)+ , KnownSymbol sch+ , KnownSymbol td+ ) => OidOf db ('PGenum labels) where+ oidOf = oidOfTypedef @sch @td+instance+ ( enums ~ DbEnums db+ , FindQualified "no enum found with labels:" enums labels ~ '(sch,td)+ , KnownSymbol sch+ , KnownSymbol td+ ) => OidOfArray db ('PGenum labels) where+ oidOfArray = oidOfArrayTypedef @sch @td++oidOfTypedef+ :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty)+ => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid+oidOfTypedef = ReaderT $ \(SOP.K conn) -> do+ resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary+ case resultMaybe of+ Nothing -> throwM $ ConnectionException oidErr+ Just result -> do+ numRows <- LibPQ.ntuples result+ when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows+ valueMaybe <- LibPQ.getvalue result 0 0+ case valueMaybe of+ Nothing -> throwM $ ConnectionException oidErr+ Just value -> case valueParser int value of+ Left err -> throwM $ DecodingException oidErr err+ Right oid -> return $ LibPQ.Oid oid+ where+ tyVal = symbolVal (SOP.Proxy @ty)+ schVal = symbolVal (SOP.Proxy @sch)+ oidErr = "oidOfTypedef " <> fromString (schVal <> "." <> tyVal)+ q = ByteString.intercalate " "+ [ "SELECT pg_type.oid"+ , "FROM pg_type"+ , "INNER JOIN pg_namespace"+ , "ON pg_type.typnamespace = pg_namespace.oid"+ , "WHERE pg_type.typname = "+ , "\'" <> fromString tyVal <> "\'"+ , "AND pg_namespace.nspname = "+ , "\'" <> fromString schVal <> "\'"+ , ";" ]++oidOfArrayTypedef+ :: forall sch ty db. (KnownSymbol sch, KnownSymbol ty)+ => ReaderT (SOP.K LibPQ.Connection db) IO LibPQ.Oid+oidOfArrayTypedef = ReaderT $ \(SOP.K conn) -> do+ resultMaybe <- LibPQ.execParams conn q [] LibPQ.Binary+ case resultMaybe of+ Nothing -> throwM $ ConnectionException oidErr+ Just result -> do+ numRows <- LibPQ.ntuples result+ when (numRows /= 1) $ throwM $ RowsException oidErr 1 numRows+ valueMaybe <- LibPQ.getvalue result 0 0+ case valueMaybe of+ Nothing -> throwM $ ConnectionException oidErr+ Just value -> case valueParser int value of+ Left err -> throwM $ DecodingException oidErr err+ Right oid -> return $ LibPQ.Oid oid+ where+ tyVal = symbolVal (SOP.Proxy @ty)+ schVal = symbolVal (SOP.Proxy @sch)+ oidErr = "oidOfArrayTypedef " <> fromString (schVal <> "." <> tyVal)+ q = ByteString.intercalate " "+ [ "SELECT pg_type.typelem"+ , "FROM pg_type"+ , "INNER JOIN pg_namespace"+ , "ON pg_type.typnamespace = pg_namespace.oid"+ , "WHERE pg_type.typname = "+ , "\'" <> fromString tyVal <> "\'"+ , "AND pg_namespace.nspname = "+ , "\'" <> fromString schVal <> "\'"+ , ";" ]
+ src/Squeal/PostgreSQL/Session/Pool.hs view
@@ -0,0 +1,138 @@+{-|+Module: Squeal.PostgreSQL.Pool+Description: connection pools+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Connection pools.++Typical use case would be to create your pool using `createConnectionPool`+and run anything that requires the pool connection with `usingConnectionPool`.++Here's a simplified example:++>>> import Squeal.PostgreSQL++>>> :{+do+ let+ qry :: Query_ (Public '[]) () (Only Char)+ qry = values_ (inline 'a' `as` #fromOnly)+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10+ chr <- usingConnectionPool pool $ do+ result <- runQuery qry+ Just (Only a) <- firstRow result+ return a+ destroyConnectionPool pool+ putChar chr+:}+a+-}++{-# LANGUAGE+ CPP+ , DeriveFunctor+ , FlexibleContexts+ , FlexibleInstances+ , InstanceSigs+ , MultiParamTypeClasses+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Session.Pool+ ( -- * Pool+ Pool+ , createConnectionPool+ , usingConnectionPool+ , destroyConnectionPool+ ) where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.ByteString+import Data.Time+import Data.Pool++import Squeal.PostgreSQL.Type.Schema+import Squeal.PostgreSQL.Session (PQ (..))+import Squeal.PostgreSQL.Session.Connection++-- | Create a striped pool of connections.+-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyConnectionPool` when you're done with the pool so that the connections are freed up as soon as possible.+createConnectionPool+ :: forall (db :: SchemasType) io. MonadIO io+ => ByteString+ -- ^ The passed string can be empty to use all default parameters, or it can+ -- contain one or more parameter settings separated by whitespace.+ -- 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 \.+ -> Int+ -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.+ -> NominalDiffTime+ -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.+ -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.+ -> Int+ -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.+ -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.+ -> io (Pool (K Connection db))+createConnectionPool conninfo stripes idle maxResrc =+#if MIN_VERSION_resource_pool(0,4,0)+ liftIO . newPool $ setNumStripes+ (Just stripes)+ (defaultPoolConfig (connectdb conninfo) finish (realToFrac idle) maxResrc)+#else+ liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc+#endif++{-|+Temporarily take a connection from a `Pool`, perform an action with it,+and return it to the pool afterwards.++If the pool has an idle connection available, it is used immediately.+Otherwise, if the maximum number of connections has not yet been reached,+a new connection is created and used.+If the maximum number of connections has been reached, this function blocks+until a connection becomes available.+-}+usingConnectionPool+ :: (MonadIO io, MonadMask io)+ => Pool (K Connection db) -- ^ pool+ -> PQ db db io x -- ^ session+ -> io x+usingConnectionPool pool (PQ session) = mask $ \restore -> do+ (conn, local) <- liftIO $ takeResource pool+ ret <- restore (session conn) `onException`+ liftIO (destroyResource pool local conn)+ liftIO $ putResource local conn+ return $ unK ret++{- |+Destroy all connections in all stripes in the pool.+Note that this will ignore any exceptions in the destroy function.++This function is useful when you detect that all connections+in the pool are broken. For example after a database has been+restarted all connections opened before the restart will be broken.+In that case it's better to close those connections so that+`usingConnectionPool` won't take a broken connection from the pool+but will open a new connection instead.++Another use-case for this function is that when you know you are done+with the pool you can destroy all idle connections immediately+instead of waiting on the garbage collector to destroy them,+thus freeing up those connections sooner.+-}+destroyConnectionPool+ :: MonadIO io+ => Pool (K Connection db) -- ^ pool+ -> io ()+destroyConnectionPool = liftIO . destroyAllResources
+ src/Squeal/PostgreSQL/Session/Result.hs view
@@ -0,0 +1,223 @@+{-|+Module: Squeal.PostgreSQL.Session.Result+Description: results+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Get values from a `Result`.+-}++{-# LANGUAGE+ FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , ScopedTypeVariables+ , TypeApplications+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Session.Result+ ( Result (..)+ , MonadResult (..)+ , liftResult+ , nextRow+ ) where++import Control.Exception (throw)+import Control.Monad (when, (<=<))+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Traversable (for)+import Text.Read (readMaybe)++import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Char8 as Char8+import qualified Data.Text.Encoding as Text+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Session.Decode+import Squeal.PostgreSQL.Session.Exception++{- | `Result`s are generated by executing+`Squeal.PostgreSQL.Session.Statement`s+in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`.++They contain an underlying `LibPQ.Result`+and a `DecodeRow`.+-}+data Result y where+ Result+ :: SOP.SListI row+ => DecodeRow row y+ -> LibPQ.Result+ -> Result y+instance Functor Result where+ fmap f (Result decode result) = Result (fmap f decode) result++{- | A `MonadResult` operation extracts values+from the `Result` of a `Squeal.PostgreSQL.Session.Monad.MonadPQ` operation.+There is no need to define instances of `MonadResult`.+An instance of `MonadIO` implies an instance of `MonadResult`.+However, the constraint `MonadResult`+does not imply the constraint `MonadIO`.+-}+class Monad m => MonadResult m where+ -- | Get a row corresponding to a given row number from a `LibPQ.Result`,+ -- throwing an exception if the row number is out of bounds.+ getRow :: LibPQ.Row -> Result y -> m y+ -- | Get all rows from a `LibPQ.Result`.+ getRows :: Result y -> m [y]+ -- | Get the first row if possible from a `LibPQ.Result`.+ firstRow :: Result y -> m (Maybe y)+ -- | Returns the number of rows (tuples) in the query result.+ ntuples :: Result y -> m LibPQ.Row+ -- | Returns the number of columns (fields) in the query result.+ nfields :: Result y -> m LibPQ.Column+ {- |+ Returns the command status tag from the SQL command+ that generated the `Result`.+ Commonly this is just the name of the command,+ but it might include additional data such as the number of rows processed.+ -}+ cmdStatus :: Result y -> m Text+ {- |+ Returns the number of rows affected by the SQL command.+ This function returns `Just` the number of+ rows affected by the SQL statement that generated the `Result`.+ This function can only be used following the execution of a+ SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH,+ or COPY statement,or an EXECUTE of a prepared query that+ contains an INSERT, UPDATE, or DELETE statement.+ If the command that generated the PGresult was anything else,+ `cmdTuples` returns `Nothing`.+ -}+ cmdTuples :: Result y -> m (Maybe LibPQ.Row)+ -- | Returns the result status of the command.+ resultStatus :: Result y -> m LibPQ.ExecStatus+ -- | Check if a `Result`'s status is either `LibPQ.CommandOk`+ -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`.+ okResult :: Result y -> m ()+ -- | Returns the error message most recently generated by an operation+ -- on the connection.+ resultErrorMessage :: Result y -> m (Maybe ByteString)+ -- | Returns the error code most recently generated by an operation+ -- on the connection.+ --+ -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html+ resultErrorCode :: Result y -> m (Maybe ByteString)++instance (Monad io, MonadIO io) => MonadResult io where+ getRow r (Result decode result) = liftIO $ do+ numRows <- LibPQ.ntuples result+ numCols <- LibPQ.nfields result+ when (numRows < r) $ throw $ RowsException "getRow" r numRows+ row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]+ case SOP.fromList row' of+ Nothing -> throw $ ColumnsException "getRow" numCols+ Just row -> case execDecodeRow decode row of+ Left parseError -> throw $ DecodingException "getRow" parseError+ Right y -> return y++ getRows (Result decode result) = liftIO $ do+ numCols <- LibPQ.nfields result+ numRows <- LibPQ.ntuples result+ for [0 .. numRows - 1] $ \ r -> do+ row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]+ case SOP.fromList row' of+ Nothing -> throw $ ColumnsException "getRows" numCols+ Just row -> case execDecodeRow decode row of+ Left parseError -> throw $ DecodingException "getRows" parseError+ Right y -> return y++ firstRow (Result decode result) = liftIO $ do+ numRows <- LibPQ.ntuples result+ numCols <- LibPQ.nfields result+ if numRows <= 0 then return Nothing else do+ row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1]+ case SOP.fromList row' of+ Nothing -> throw $ ColumnsException "firstRow" numCols+ Just row -> case execDecodeRow decode row of+ Left parseError -> throw $ DecodingException "firstRow" parseError+ Right y -> return $ Just y++ ntuples = liftResult LibPQ.ntuples++ nfields = liftResult LibPQ.nfields++ resultStatus = liftResult LibPQ.resultStatus++ cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus)+ where+ getCmdStatus = \case+ Nothing -> throwM $ ConnectionException "LibPQ.cmdStatus"+ Just bytes -> return $ Text.decodeUtf8 bytes++ cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples)+ where+ getCmdTuples = \case+ Nothing -> throwM $ ConnectionException "LibPQ.cmdTuples"+ Just bytes -> return $+ if ByteString.null bytes+ then Nothing+ else fromInteger <$> readMaybe (Char8.unpack bytes)++ okResult = liftResult okResult_ ++ resultErrorMessage = liftResult LibPQ.resultErrorMessage++ resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)++-- | Intended to be used for unfolding in streaming libraries, `nextRow`+-- takes a total number of rows (which can be found with `ntuples`)+-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,+-- otherwise returning the row along with the next row number.+nextRow+ :: MonadIO io+ => LibPQ.Row -- ^ total number of rows+ -> Result y -- ^ result+ -> LibPQ.Row -- ^ row number+ -> io (Maybe (LibPQ.Row, y))+nextRow total (Result decode result) r+ = liftIO $ if r >= total then return Nothing else do+ numCols <- LibPQ.nfields result+ row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]+ case SOP.fromList row' of+ Nothing -> throw $ ColumnsException "nextRow" numCols+ Just row -> case execDecodeRow decode row of+ Left parseError -> throw $ DecodingException "nextRow" parseError+ Right y -> return $ Just (r+1, y)++okResult_ :: MonadIO io => LibPQ.Result -> io ()+okResult_ result = liftIO $ do+ status <- LibPQ.resultStatus result+ case status of+ LibPQ.CommandOk -> return ()+ LibPQ.TuplesOk -> return ()+ _ -> do+ stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate+ case stateCodeMaybe of+ Nothing -> throw $ ConnectionException "LibPQ.resultErrorField"+ Just stateCode -> do+ msgMaybe <- LibPQ.resultErrorMessage result+ case msgMaybe of+ Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage"+ Just msg -> throw . SQLException $ SQLState status stateCode msg++-- | Lifts actions on results from @LibPQ@.+liftResult+ :: MonadIO io+ => (LibPQ.Result -> IO x)+ -> Result y -> io x+liftResult f (Result _ result) = liftIO $ f result++execDecodeRow+ :: DecodeRow row y+ -> SOP.NP (SOP.K (Maybe ByteString)) row+ -> Either Text y+execDecodeRow decode = runDecodeRow decode
+ src/Squeal/PostgreSQL/Session/Statement.hs view
@@ -0,0 +1,220 @@+{-|+Module: Squeal.PostgreSQL.Session.Statement+Description: statements+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++A top-level `Statement` type wraps a `Squeal.PostgreSQL.Query.Query`+or `Squeal.PostgreSQL.Manipulation.Manipulation`+together with an `EncodeParams` and a `DecodeRow`.+-}++{-# LANGUAGE+ DataKinds+ , DeriveFunctor+ , DeriveFoldable+ , DeriveGeneric+ , DeriveTraversable+ , FlexibleContexts+ , GADTs+ , RankNTypes+#-}++module Squeal.PostgreSQL.Session.Statement+ ( -- * Statement+ Statement (..)+ , query+ , manipulation+ -- * Prepared+ , Prepared (..)+ ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Monad+import Control.Monad.Fix+import Data.Functor.Contravariant+import Data.Profunctor+import Data.Profunctor.Traversing+import GHC.Generics+import Prelude hiding ((.),id)++import qualified Generics.SOP as SOP++import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Session.Decode+import Squeal.PostgreSQL.Session.Encode+import Squeal.PostgreSQL.Session.Oid+import Squeal.PostgreSQL.Query+import Squeal.PostgreSQL.Render hiding ((<+>))++-- | A `Statement` consists of a `Squeal.PostgreSQL.Statement.Manipulation`+-- or a `Squeal.PostgreSQL.Session.Statement.Query` that can be run+-- in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`.+data Statement db x y where+ -- | Constructor for a data manipulation language `Statement`+ Manipulation+ :: (SOP.All (OidOfNull db) params, SOP.SListI row)+ => EncodeParams db params x -- ^ encoding of parameters+ -> DecodeRow row y -- ^ decoding of returned rows+ -> Manipulation '[] db params row+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ...+ -> Statement db x y+ -- | Constructor for a structured query language `Statement`+ Query+ :: (SOP.All (OidOfNull db) params, SOP.SListI row)+ => EncodeParams db params x -- ^ encoding of parameters+ -> DecodeRow row y -- ^ decoding of returned rows+ -> Query '[] '[] db params row+ -- ^ `Squeal.PostgreSQL.Query.Select.select`,+ -- `Squeal.PostgreSQL.Query.Values.values`, ...+ -> Statement db x y++instance Profunctor (Statement db) where+ lmap f (Manipulation encode decode q) =+ Manipulation (contramap f encode) decode q+ lmap f (Query encode decode q) =+ Query (contramap f encode) decode q+ rmap f (Manipulation encode decode q) =+ Manipulation encode (fmap f decode) q+ rmap f (Query encode decode q) =+ Query encode (fmap f decode) q+ dimap f g (Manipulation encode decode q) =+ Manipulation (contramap f encode) (fmap g decode) q+ dimap f g (Query encode decode q) =+ Query (contramap f encode) (fmap g decode) q++instance Functor (Statement db x) where fmap = rmap++instance RenderSQL (Statement db x y) where+ renderSQL (Manipulation _ _ q) = renderSQL q+ renderSQL (Query _ _ q) = renderSQL q++-- | Smart constructor for a structured query language `Statement`+query ::+ ( GenericParams db params x xs+ , GenericRow row y ys+ ) => Query '[] '[] db params row+ -- ^ `Squeal.PostgreSQL.Query.Select.select`,+ -- `Squeal.PostgreSQL.Query.Values.values`, ...+ -> Statement db x y+query = Query genericParams genericRow++-- | Smart constructor for a data manipulation language `Statement`+manipulation ::+ ( GenericParams db params x xs+ , GenericRow row y ys+ ) => Manipulation '[] db params row+ -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,+ -- `Squeal.PostgreSQL.Manipulation.Update.update`,+ -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ...+ -> Statement db x y+manipulation = Manipulation genericParams genericRow++{- |+`Squeal.PostgreSQL.Session.Monad.prepare` and+`Squeal.PostgreSQL.Session.Monad.prepare_` create a `Prepared` statement.+A `Prepared` statement is a server-side object+that can be used to optimize performance.+When `Squeal.PostgreSQL.Session.Monad.prepare`+or `Squeal.PostgreSQL.Session.Monad.prepare_` is executed,+the specified `Statement` is parsed, analyzed, and rewritten.++When the `runPrepared` command is subsequently issued,+the `Prepared` statement is planned and executed.+This division of labor avoids repetitive parse analysis work,+while allowing the execution plan to+depend on the specific parameter values supplied.++`Prepared` statements only last for the duration+of the current database session.+`Prepared` statements can be manually cleaned up+using the `deallocate` command.+-}+data Prepared m x y = Prepared+ { runPrepared :: x -> m y -- ^ execute a prepared statement+ , deallocate :: m () -- ^ manually clean up a prepared statement+ } deriving (Functor, Generic, Generic1)++instance Applicative m => Applicative (Prepared m x) where+ pure a = Prepared (\_ -> pure a) (pure ())+ p1 <*> p2 = Prepared+ (run2 (<*>) p1 p2)+ (deallocate p1 *> deallocate p2)++instance Alternative m => Alternative (Prepared m x) where+ empty = Prepared (runKleisli empty) empty+ p1 <|> p2 = Prepared+ (run2 (<|>) p1 p2)+ (deallocate p1 *> deallocate p2)++instance Functor m => Profunctor (Prepared m) where+ dimap g f prepared = Prepared+ (fmap f . runPrepared prepared . g)+ (deallocate prepared)++instance Monad m => Strong (Prepared m) where+ first' p = Prepared (run1 first' p) (deallocate p)+ second' p = Prepared (run1 second' p) (deallocate p)++instance Monad m => Choice (Prepared m) where+ left' p = Prepared (run1 left' p) (deallocate p)+ right' p = Prepared (run1 right' p) (deallocate p)++instance MonadFix m => Costrong (Prepared m) where+ unfirst p = Prepared (run1 unfirst p) (deallocate p)+ unsecond p = Prepared (run1 unsecond p) (deallocate p)++instance Monad m => Category (Prepared m) where+ id = Prepared return (return ())+ cd . ab = Prepared+ (runPrepared ab >=> runPrepared cd)+ (deallocate ab >> deallocate cd)++instance Monad m => Arrow (Prepared m) where+ arr ab = Prepared (return . ab) (return ())+ first = first'+ second = second'+ ab *** cd = first ab >>> second cd+ ab &&& ac = Prepared+ (run2 (&&&) ab ac)+ (deallocate ab >> deallocate ac)++instance Monad m => ArrowChoice (Prepared m) where+ left = left'+ right = right'+ ab +++ cd = left ab >>> right cd+ bd ||| cd = Prepared+ (run2 (|||) bd cd)+ (deallocate bd >> deallocate cd)++instance MonadFix m => ArrowLoop (Prepared m) where+ loop p = Prepared (run1 loop p) (deallocate p)++instance MonadPlus m => ArrowZero (Prepared m) where+ zeroArrow = Prepared (runKleisli zeroArrow) (return ())++instance MonadPlus m => ArrowPlus (Prepared m) where+ p1 <+> p2 = Prepared+ (run2 (<+>) p1 p2)+ (deallocate p1 >> deallocate p2)++instance Monad m => Traversing (Prepared m) where+ traverse' p = Prepared (run1 traverse' p) (deallocate p)++-- helper functions++run1+ :: (Kleisli m a b -> Kleisli m c d)+ -> Prepared m a b -> c -> m d+run1 m = runKleisli . m . Kleisli . runPrepared++run2+ :: (Kleisli m a b -> Kleisli m c d -> Kleisli m e f)+ -> Prepared m a b -> Prepared m c d -> e -> m f+run2 (?) p1 p2 = runKleisli $+ Kleisli (runPrepared p1) ? Kleisli (runPrepared p2)
+ src/Squeal/PostgreSQL/Session/Transaction.hs view
@@ -0,0 +1,156 @@+{-|+Module: Squeal.PostgreSQL.Session.Transaction+Description: transaction control language+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++transaction control language+-}++{-# LANGUAGE+ MonoLocalBinds+ , RankNTypes+#-}++module Squeal.PostgreSQL.Session.Transaction+ ( -- * Transaction+ Transaction+ , transactionally+ , transactionally_+ , transactionallyRetry+ , transactionallyRetry_+ , ephemerally+ , ephemerally_+ , withSavepoint+ -- * Transaction Mode+ , TransactionMode (..)+ , defaultMode+ , longRunningMode+ , retryMode+ , IsolationLevel (..)+ , AccessMode (..)+ , DeferrableMode (..)+ ) where++import Control.Monad.Catch+import Data.ByteString++import Squeal.PostgreSQL.Session.Monad+import Squeal.PostgreSQL.Session.Result+import Squeal.PostgreSQL.Session.Transaction.Unsafe+ ( TransactionMode (..)+ , defaultMode+ , longRunningMode+ , retryMode+ , IsolationLevel (..)+ , AccessMode (..)+ , DeferrableMode (..)+ )+import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe++{- | A type of "safe" `Transaction`s,+do-blocks that permit only+database operations, pure functions, and synchronous exception handling+forbidding arbitrary `IO` operations.++To permit arbitrary `IO`,++>>> import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe++Then use the @Unsafe@ qualified form of the functions below.++A safe `Transaction` can be run in two ways,++1) it can be run directly in `IO` because as a+ universally quantified type,+ @Transaction db x@ permits interpretation in "subtypes" like+ @(MonadPQ db m, MonadIO m, MonadCatch m) => m x@+ or+ @PQ db db IO x@++2) it can be run in a transaction block, using+ `transactionally`, `ephemerally`,+ or `transactionallyRetry`+-} +type Transaction db x = forall m.+ ( MonadPQ db m+ , MonadResult m+ , MonadCatch m+ ) => m x++{- | Run a computation `transactionally`;+first `Unsafe.begin`,+then run the computation,+`onException` `Unsafe.rollback` and rethrow the exception,+otherwise `Unsafe.commit` and `return` the result.+-}+transactionally+ :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+ => TransactionMode+ -> Transaction db x -- ^ run inside a transaction+ -> tx x+transactionally mode tx = Unsafe.transactionally mode tx++-- | Run a computation `transactionally_`, in `defaultMode`.+transactionally_+ :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+ => Transaction db x -- ^ run inside a transaction+ -> tx x+transactionally_ tx = Unsafe.transactionally_ tx++{- |+`transactionallyRetry` a computation;++* first `Unsafe.begin`,+* then `try` the computation,+ - if it raises a serialization failure or deadloack detection,+ then `Unsafe.rollback` and restart the transaction,+ - if it raises any other exception then `Unsafe.rollback` and rethrow the exception,+ - otherwise `Unsafe.commit` and `return` the result.+-}+transactionallyRetry+ :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+ => TransactionMode+ -> Transaction db x -- ^ run inside a transaction+ -> tx x+transactionallyRetry mode tx = Unsafe.transactionallyRetry mode tx++{- | `transactionallyRetry` in `retryMode`. -}+transactionallyRetry_+ :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+ => Transaction db x -- ^ run inside a transaction+ -> tx x+transactionallyRetry_ tx = Unsafe.transactionallyRetry_ tx++{- | Run a computation `ephemerally`;+Like `transactionally` but always `Unsafe.rollback`, useful in testing.+-}+ephemerally+ :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+ => TransactionMode+ -> Transaction db x -- ^ run inside an ephemeral transaction+ -> tx x+ephemerally mode tx = Unsafe.ephemerally mode tx++{- | Run a computation `ephemerally` in `defaultMode`. -}+ephemerally_+ :: (MonadMask tx, MonadResult tx, MonadPQ db tx)+ => Transaction db x -- ^ run inside an ephemeral transaction+ -> tx x+ephemerally_ tx = Unsafe.ephemerally_ tx++{- | `withSavepoint`, used in a transaction block,+allows a form of nested transactions,+creating a savepoint, then running a transaction,+rolling back to the savepoint if it returned `Left`,+then releasing the savepoint and returning transaction's result.++Make sure to run `withSavepoint` in a transaction block,+not directly or you will provoke a SQL exception.+-}+withSavepoint+ :: ByteString -- ^ savepoint name+ -> Transaction db (Either e x)+ -> Transaction db (Either e x)+withSavepoint sv tx = Unsafe.withSavepoint sv tx
+ src/Squeal/PostgreSQL/Session/Transaction/Unsafe.hs view
@@ -0,0 +1,300 @@+{-|+Module: Squeal.PostgreSQL.Session.Transaction.Unsafe+Description: unsafe transaction control language+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++transaction control language permitting arbitrary `IO`+-}++{-# LANGUAGE+ DataKinds+ , FlexibleContexts+ , LambdaCase+ , OverloadedStrings+ , DataKinds+ , PolyKinds+#-}++module Squeal.PostgreSQL.Session.Transaction.Unsafe+ ( -- * Transaction+ transactionally+ , transactionally_+ , transactionallyRetry+ , transactionallyRetry_+ , ephemerally+ , ephemerally_+ , begin+ , commit+ , rollback+ , withSavepoint+ -- * Transaction Mode+ , TransactionMode (..)+ , defaultMode+ , retryMode+ , longRunningMode+ , IsolationLevel (..)+ , AccessMode (..)+ , DeferrableMode (..)+ ) where++import Control.Monad+import Control.Monad.Catch+import Data.ByteString+import Data.Either++import Squeal.PostgreSQL.Manipulation+import Squeal.PostgreSQL.Render+import Squeal.PostgreSQL.Session.Exception+import Squeal.PostgreSQL.Session.Monad++{- | Run a computation `transactionally`;+first `begin`,+then run the computation,+`onException` `rollback` and rethrow the exception,+otherwise `commit` and `return` the result.+-}+transactionally+ :: (MonadMask tx, MonadPQ db tx)+ => TransactionMode+ -> tx x -- ^ run inside a transaction+ -> tx x+transactionally mode tx = mask $ \restore -> do+ manipulate_ $ begin mode+ result <- restore tx `onException` manipulate_ rollback+ manipulate_ commit+ return result++-- | Run a computation `transactionally_`, in `defaultMode`.+transactionally_+ :: (MonadMask tx, MonadPQ db tx)+ => tx x -- ^ run inside a transaction+ -> tx x+transactionally_ = transactionally defaultMode++{- |+`transactionallyRetry` a computation;++* first `begin`,+* then `try` the computation,+ - if it raises a serialization failure or deadlock detection,+ then `rollback` and restart the transaction,+ - if it raises any other exception then `rollback` and rethrow the exception,+ - otherwise `commit` and `return` the result.+-}+transactionallyRetry+ :: (MonadMask tx, MonadPQ db tx)+ => TransactionMode+ -> tx x -- ^ run inside a transaction+ -> tx x+transactionallyRetry mode tx = mask $ \restore ->+ loop . try $ do+ x <- restore tx+ manipulate_ commit+ return x+ where+ loop attempt = do+ manipulate_ $ begin mode+ attempt >>= \case+ Left (SerializationFailure _) -> do+ manipulate_ rollback+ loop attempt+ Left (DeadlockDetected _) -> do+ manipulate_ rollback+ loop attempt+ Left err -> do+ manipulate_ rollback+ throwM err+ Right x -> return x++{- | `transactionallyRetry` in `retryMode`. -}+transactionallyRetry_+ :: (MonadMask tx, MonadPQ db tx)+ => tx x -- ^ run inside a transaction+ -> tx x+transactionallyRetry_ = transactionallyRetry retryMode++{- | Run a computation `ephemerally`;+Like `transactionally` but always `rollback`, useful in testing.+-}+ephemerally+ :: (MonadMask tx, MonadPQ db tx)+ => TransactionMode+ -> tx x -- ^ run inside an ephemeral transaction+ -> tx x+ephemerally mode tx = mask $ \restore -> do+ manipulate_ $ begin mode+ result <- restore tx `onException` (manipulate_ rollback)+ manipulate_ rollback+ return result++{- | Run a computation `ephemerally` in `defaultMode`. -}+ephemerally_+ :: (MonadMask tx, MonadPQ db tx)+ => tx x -- ^ run inside an ephemeral transaction+ -> tx x+ephemerally_ = ephemerally defaultMode++-- | @BEGIN@ a transaction.+begin :: TransactionMode -> Manipulation_ db () ()+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode++-- | @COMMIT@ a transaction.+commit :: Manipulation_ db () ()+commit = UnsafeManipulation "COMMIT"++-- | @ROLLBACK@ a transaction.+rollback :: Manipulation_ db () ()+rollback = UnsafeManipulation "ROLLBACK"++{- | `withSavepoint`, used in a transaction block,+allows a form of nested transactions,+creating a savepoint, then running a transaction,+rolling back to the savepoint if it returned `Left`,+then releasing the savepoint and returning transaction's result.++Make sure to run `withSavepoint` in a transaction block,+not directly or you will provoke a SQL exception.+-}+withSavepoint+ :: MonadPQ db tx+ => ByteString -- ^ savepoint name+ -> tx (Either e x)+ -> tx (Either e x)+withSavepoint savepoint tx = do+ let svpt = "SAVEPOINT" <+> savepoint+ manipulate_ $ UnsafeManipulation $ svpt+ e_x <- tx+ when (isLeft e_x) $+ manipulate_ $ UnsafeManipulation $ "ROLLBACK TO" <+> svpt+ manipulate_ $ UnsafeManipulation $ "RELEASE" <+> svpt+ return e_x++-- | The available transaction characteristics are the transaction `IsolationLevel`,+-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.+data TransactionMode = TransactionMode+ { isolationLevel :: IsolationLevel+ , accessMode :: AccessMode+ , deferrableMode :: DeferrableMode+ } deriving (Show, Eq)++-- | `TransactionMode` with a `ReadCommitted` `IsolationLevel`,+-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.+defaultMode :: TransactionMode+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable++-- | `TransactionMode` with a `Serializable` `IsolationLevel`,+-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`,+-- appropriate for short-lived queries or manipulations.+retryMode :: TransactionMode+retryMode = TransactionMode Serializable ReadWrite NotDeferrable++-- | `TransactionMode` with a `Serializable` `IsolationLevel`,+-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.+-- This mode is well suited for long-running reports or backups.+longRunningMode :: TransactionMode+longRunningMode = TransactionMode Serializable ReadOnly Deferrable++-- | Render a `TransactionMode`.+instance RenderSQL TransactionMode where+ renderSQL mode =+ "ISOLATION LEVEL"+ <+> renderSQL (isolationLevel mode)+ <+> renderSQL (accessMode mode)+ <+> renderSQL (deferrableMode mode)++-- | The SQL standard defines four levels of transaction isolation.+-- The most strict is `Serializable`, which is defined by the standard in a paragraph+-- which says that any concurrent execution of a set of `Serializable` transactions is+-- guaranteed to produce the same effect as running them one at a time in some order.+-- The other three levels are defined in terms of phenomena, resulting from interaction+-- between concurrent transactions, which must not occur at each level.+-- The phenomena which are prohibited at various levels are:+--+-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.+--+-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data+-- has been modified by another transaction (that committed since the initial read).+--+-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy+-- a search condition and finds that the set of rows satisfying the condition+-- has changed due to another recently-committed transaction.+--+-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent+-- with all possible orderings of running those transactions one at a time.+--+-- In PostgreSQL, you can request any of the four standard transaction+-- isolation levels, but internally only three distinct isolation levels are implemented,+-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.+-- This is because it is the only sensible way to map the standard isolation levels to+-- PostgreSQL's multiversion concurrency control architecture.+data IsolationLevel+ = Serializable+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is not possible.+ -- Phantom read is not possible.+ -- Serialization anomaly is not possible.+ | RepeatableRead+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is not possible.+ -- Phantom read is not possible.+ -- Serialization anomaly is possible.+ | ReadCommitted+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is possible.+ -- Phantom read is possible.+ -- Serialization anomaly is possible.+ | ReadUncommitted+ -- ^ Dirty read is not possible.+ -- Nonrepeatable read is possible.+ -- Phantom read is possible.+ -- Serialization anomaly is possible.+ deriving (Show, Eq)++-- | Render an `IsolationLevel`.+instance RenderSQL IsolationLevel where+ renderSQL = \case+ Serializable -> "SERIALIZABLE"+ ReadCommitted -> "READ COMMITTED"+ ReadUncommitted -> "READ UNCOMMITTED"+ RepeatableRead -> "REPEATABLE READ"++-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.+-- `ReadWrite` is the default. When a transaction is `ReadOnly`,+-- the following SQL commands are disallowed:+-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@+-- if the table they would write to is not a temporary table;+-- all @CREATE@, @ALTER@, and @DROP@ commands;+-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;+-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.+-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.+data AccessMode+ = ReadWrite+ | ReadOnly+ deriving (Show, Eq)++-- | Render an `AccessMode`.+instance RenderSQL AccessMode where+ renderSQL = \case+ ReadWrite -> "READ WRITE"+ ReadOnly -> "READ ONLY"++-- | The `Deferrable` transaction property has no effect+-- unless the transaction is also `Serializable` and `ReadOnly`.+-- When all three of these properties are selected for a transaction,+-- the transaction may block when first acquiring its snapshot,+-- after which it is able to run without the normal overhead of a+-- `Serializable` transaction and without any risk of contributing+-- to or being canceled by a serialization failure.+-- This `longRunningMode` is well suited for long-running reports or backups.+data DeferrableMode+ = Deferrable+ | NotDeferrable+ deriving (Show, Eq)++-- | Render a `DeferrableMode`.+instance RenderSQL DeferrableMode where+ renderSQL = \case+ Deferrable -> "DEFERRABLE"+ NotDeferrable -> "NOT DEFERRABLE"
− src/Squeal/PostgreSQL/Transaction.hs
@@ -1,252 +0,0 @@-{-|-Module: Squeal.PostgreSQL.Transaction-Description: Squeal transaction control language-Copyright: (c) Eitan Chatav, 2019-Maintainer: eitan@morphism.tech-Stability: experimental--Squeal transaction control language.--}--{-# LANGUAGE- DataKinds- , FlexibleContexts- , LambdaCase- , OverloadedStrings- , TypeInType-#-}--module Squeal.PostgreSQL.Transaction- ( -- * Transaction- transactionally- , transactionally_- , transactionallyRetry- , ephemerally- , ephemerally_- , begin- , commit- , rollback- -- * Transaction Mode- , TransactionMode (..)- , defaultMode- , longRunningMode- , IsolationLevel (..)- , AccessMode (..)- , DeferrableMode (..)- ) where--import UnliftIO--import Squeal.PostgreSQL.Manipulation-import Squeal.PostgreSQL.Render-import Squeal.PostgreSQL.PQ--{- | Run a computation `transactionally`;-first `begin`,-then run the computation,-`onException` `rollback` and rethrow the exception,-otherwise `commit` and `return` the result.--}-transactionally- :: (MonadUnliftIO tx, MonadPQ schemas tx)- => TransactionMode- -> tx x -- ^ run inside a transaction- -> tx x-transactionally mode tx = mask $ \restore -> do- manipulate_ $ begin mode- result <- restore tx `onException` (manipulate_ rollback)- manipulate_ commit- return result---- | Run a computation `transactionally_`, in `defaultMode`.-transactionally_- :: (MonadUnliftIO tx, MonadPQ schemas tx)- => tx x -- ^ run inside a transaction- -> tx x-transactionally_ = transactionally defaultMode--{- |-`transactionallyRetry` a computation;--* first `begin`,-* then `try` the computation,- - if it raises a serialization failure then `rollback` and restart the transaction,- - if it raises any other exception then `rollback` and rethrow the exception,- - otherwise `commit` and `return` the result.--}-transactionallyRetry- :: (MonadUnliftIO tx, MonadPQ schemas tx)- => TransactionMode- -> tx x -- ^ run inside a transaction- -> tx x-transactionallyRetry mode tx = mask $ \restore ->- loop . try $ do- x <- restore tx- manipulate_ commit- return x- where- loop attempt = do- manipulate_ $ begin mode- attempt >>= \case- Left (PQException (PQState _ (Just "40001") _)) -> do- manipulate_ rollback- loop attempt- Left err -> do- manipulate_ rollback- throwIO err- Right x -> return x--{- | Run a computation `ephemerally`;-Like `transactionally` but always `rollback`, useful in testing.--}-ephemerally- :: (MonadUnliftIO tx, MonadPQ schemas tx)- => TransactionMode- -> tx x -- ^ run inside an ephemeral transaction- -> tx x-ephemerally mode tx = mask $ \restore -> do- manipulate_ $ begin mode- result <- restore tx `onException` (manipulate_ rollback)- manipulate_ rollback- return result--{- | Run a computation `ephemerally` in `defaultMode`. -}-ephemerally_- :: (MonadUnliftIO tx, MonadPQ schemas tx)- => tx x -- ^ run inside an ephemeral transaction- -> tx x-ephemerally_ = ephemerally defaultMode---- | @BEGIN@ a transaction.-begin :: TransactionMode -> Manipulation_ schemas () ()-begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode---- | @COMMIT@ a transaction.-commit :: Manipulation_ schemas () ()-commit = UnsafeManipulation "COMMIT"---- | @ROLLBACK@ a transaction.-rollback :: Manipulation_ schemas () ()-rollback = UnsafeManipulation "ROLLBACK"---- | The available transaction characteristics are the transaction `IsolationLevel`,--- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.-data TransactionMode = TransactionMode- { isolationLevel :: IsolationLevel- , accessMode :: AccessMode- , deferrableMode :: DeferrableMode- } deriving (Show, Eq)---- | `TransactionMode` with a `Serializable` `IsolationLevel`,--- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.-defaultMode :: TransactionMode-defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable---- | `TransactionMode` with a `Serializable` `IsolationLevel`,--- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.--- This mode is well suited for long-running reports or backups.-longRunningMode :: TransactionMode-longRunningMode = TransactionMode Serializable ReadOnly Deferrable---- | Render a `TransactionMode`.-instance RenderSQL TransactionMode where- renderSQL mode =- "ISOLATION LEVEL"- <+> renderSQL (isolationLevel mode)- <+> renderSQL (accessMode mode)- <+> renderSQL (deferrableMode mode)---- | The SQL standard defines four levels of transaction isolation.--- The most strict is `Serializable`, which is defined by the standard in a paragraph--- which says that any concurrent execution of a set of `Serializable` transactions is--- guaranteed to produce the same effect as running them one at a time in some order.--- The other three levels are defined in terms of phenomena, resulting from interaction--- between concurrent transactions, which must not occur at each level.--- The phenomena which are prohibited at various levels are:------ __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.------ __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data--- has been modified by another transaction (that committed since the initial read).------ __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy--- a search condition and finds that the set of rows satisfying the condition--- has changed due to another recently-committed transaction.------ __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent--- with all possible orderings of running those transactions one at a time.------ In PostgreSQL, you can request any of the four standard transaction--- isolation levels, but internally only three distinct isolation levels are implemented,--- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.--- This is because it is the only sensible way to map the standard isolation levels to--- PostgreSQL's multiversion concurrency control architecture.-data IsolationLevel- = Serializable- -- ^ Dirty read is not possible.- -- Nonrepeatable read is not possible.- -- Phantom read is not possible.- -- Serialization anomaly is not possible.- | RepeatableRead- -- ^ Dirty read is not possible.- -- Nonrepeatable read is not possible.- -- Phantom read is not possible.- -- Serialization anomaly is possible.- | ReadCommitted- -- ^ Dirty read is not possible.- -- Nonrepeatable read is possible.- -- Phantom read is possible.- -- Serialization anomaly is possible.- | ReadUncommitted- -- ^ Dirty read is not possible.- -- Nonrepeatable read is possible.- -- Phantom read is possible.- -- Serialization anomaly is possible.- deriving (Show, Eq)---- | Render an `IsolationLevel`.-instance RenderSQL IsolationLevel where- renderSQL = \case- Serializable -> "SERIALIZABLE"- ReadCommitted -> "READ COMMITTED"- ReadUncommitted -> "READ UNCOMMITTED"- RepeatableRead -> "REPEATABLE READ"---- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.--- `ReadWrite` is the default. When a transaction is `ReadOnly`,--- the following SQL commands are disallowed:--- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@--- if the table they would write to is not a temporary table;--- all @CREATE@, @ALTER@, and @DROP@ commands;--- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;--- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.--- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.-data AccessMode- = ReadWrite- | ReadOnly- deriving (Show, Eq)---- | Render an `AccessMode`.-instance RenderSQL AccessMode where- renderSQL = \case- ReadWrite -> "READ WRITE"- ReadOnly -> "READ ONLY"---- | The `Deferrable` transaction property has no effect--- unless the transaction is also `Serializable` and `ReadOnly`.--- When all three of these properties are selected for a transaction,--- the transaction may block when first acquiring its snapshot,--- after which it is able to run without the normal overhead of a--- `Serializable` transaction and without any risk of contributing--- to or being canceled by a serialization failure.--- This `longRunningMode` is well suited for long-running reports or backups.-data DeferrableMode- = Deferrable- | NotDeferrable- deriving (Show, Eq)---- | Render a `DeferrableMode`.-instance RenderSQL DeferrableMode where- renderSQL = \case- Deferrable -> "DEFERRABLE"- NotDeferrable -> "NOT DEFERRABLE"
+ src/Squeal/PostgreSQL/Type.hs view
@@ -0,0 +1,202 @@+{-|+Module: Squeal.PostgreSQL.Type+Description: types+Copyright: (c) Eitan Chatav, 2010+Maintainer: eitan@morphism.tech+Stability: experimental++storage newtypes+-}+{-# LANGUAGE+ AllowAmbiguousTypes+ , DeriveAnyClass+ , DeriveFoldable+ , DeriveFunctor+ , DeriveGeneric+ , DeriveTraversable+ , DerivingStrategies+ , DefaultSignatures+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Type+ ( -- * Storage newtypes+ Money (..)+ , Json (..)+ , Jsonb (..)+ , Composite (..)+ , Enumerated (..)+ , VarArray (..)+ , FixArray (..)+ , VarChar, varChar, getVarChar+ , FixChar, fixChar, getFixChar+ , Only (..)+ ) where++import Data.Proxy+import Data.Int (Int64)+import GHC.TypeLits++import qualified Data.Text as Strict (Text)+import qualified Data.Text as Strict.Text+import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++-- $setup+-- >>> import Squeal.PostgreSQL++{- | The `Money` newtype stores a monetary value in terms+of the number of cents, i.e. @$2,000.20@ would be expressed as+@Money { cents = 200020 }@.++>>> :kind! PG Money+PG Money :: PGType+= 'PGmoney+-}+newtype Money = Money { cents :: Int64 }+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++{- | The `Json` newtype is an indication that the Haskell+type it's applied to should be stored as a+`Squeal.PostgreSQL.Type.Schema.PGjson`.++>>> :kind! PG (Json [String])+PG (Json [String]) :: PGType+= 'PGjson+-}+newtype Json hask = Json {getJson :: hask}+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++{- | The `Jsonb` newtype is an indication that the Haskell+type it's applied to should be stored as a+`Squeal.PostgreSQL.Type.Schema.PGjsonb`.++>>> :kind! PG (Jsonb [String])+PG (Jsonb [String]) :: PGType+= 'PGjsonb+-}+newtype Jsonb hask = Jsonb {getJsonb :: hask}+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++{- | The `Composite` newtype is an indication that the Haskell+type it's applied to should be stored as a+`Squeal.PostgreSQL.Type.Schema.PGcomposite`.++>>> :{+data Complex = Complex+ { real :: Double+ , imaginary :: Double+ } deriving stock GHC.Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+:}++>>> :kind! PG (Composite Complex)+PG (Composite Complex) :: PGType+= 'PGcomposite+ '["real" ::: 'NotNull 'PGfloat8,+ "imaginary" ::: 'NotNull 'PGfloat8]+-}+newtype Composite record = Composite {getComposite :: record}+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++{- | The `Enumerated` newtype is an indication that the Haskell+type it's applied to should be stored as a+`Squeal.PostgreSQL.Type.Schema.PGenum`.++>>> :kind! PG (Enumerated Ordering)+PG (Enumerated Ordering) :: PGType+= 'PGenum '["LT", "EQ", "GT"]+-}+newtype Enumerated enum = Enumerated {getEnumerated :: enum}+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++{- | The `VarArray` newtype is an indication that the Haskell+type it's applied to should be stored as a+`Squeal.PostgreSQL.Type.Schema.PGvararray`.++>>> import Data.Vector+>>> :kind! PG (VarArray (Vector Double))+PG (VarArray (Vector Double)) :: PGType+= 'PGvararray ('NotNull 'PGfloat8)+-}+newtype VarArray arr+ = VarArray {getVarArray :: arr}+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++{- | The `FixArray` newtype is an indication that the Haskell+type it's applied to should be stored as a+`Squeal.PostgreSQL.Type.Schema.PGfixarray`.++>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))+PG (FixArray ((Double, Double), (Double, Double))) :: PGType+= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)+-}+newtype FixArray arr = FixArray {getFixArray :: arr}+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)++-- | `Only` is a 1-tuple type, useful for encoding or decoding a singleton+newtype Only x = Only { fromOnly :: x }+ deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)+instance SOP.Generic (Only x)+instance SOP.HasDatatypeInfo (Only x)++{- | Variable-length text type with limit++>>> :kind! PG (VarChar 4)+PG (VarChar 4) :: PGType+= 'PGvarchar 4+-}+newtype VarChar (n :: Nat) = VarChar Strict.Text+ deriving (Eq,Ord,Read,Show)++-- | Constructor for `VarChar`+varChar :: forall n . KnownNat n => Strict.Text -> Maybe (VarChar n)+varChar t =+ if Strict.Text.length t <= fromIntegral (natVal @n Proxy)+ then Just $ VarChar t+ else Nothing++-- | Access the `Strict.Text` of a `VarChar`+getVarChar :: VarChar n -> Strict.Text+getVarChar (VarChar t) = t++{- | Fixed-length, blank padded++>>> :kind! PG (FixChar 4)+PG (FixChar 4) :: PGType+= 'PGchar 4+-}+newtype FixChar (n :: Nat) = FixChar Strict.Text+ deriving (Eq,Ord,Read,Show)++-- | Constructor for `FixChar`+fixChar :: forall n . KnownNat n => Strict.Text -> Maybe (FixChar n)+fixChar t =+ if Strict.Text.length t == fromIntegral (natVal @n Proxy)+ then Just $ FixChar t+ else Nothing++-- | Access the `Strict.Text` of a `FixChar`+getFixChar :: FixChar n -> Strict.Text+getFixChar (FixChar t) = t
+ src/Squeal/PostgreSQL/Type/Alias.hs view
@@ -0,0 +1,349 @@+{-|+Module: Squeal.PostgreSQL.Type.Alias+Description: aliases+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++This module embeds Postgres's alias system in Haskell in+a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,+Squeal can reference aliases by prepending with a @#@.+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilyDependencies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Type.Alias+ ( -- * Aliases+ (:::)+ , Alias (..)+ , IsLabel (..)+ , Aliased (As)+ , Aliasable (as)+ , renderAliased+ , mapAliased+ , Has+ , HasUnique+ , HasErr+ , HasAll+ , HasIn+ -- * Qualified Aliases+ , QualifiedAlias (..)+ , IsQualified (..)+ -- * Grouping+ , Grouping (..)+ , GroupedBy+ -- * Error reporting+ , LookupFailedError+ , PrettyPrintHaystack+ , PrettyPrintInfo(..)+ , MismatchError+ , LookupFailedError'+ , DefaultPrettyPrinter+ , MismatchError'+ ) where++import Control.DeepSeq+import Data.ByteString (ByteString)+import Data.String (fromString)+import GHC.Exts (Any, Constraint)+import GHC.OverloadedLabels+import GHC.TypeLits++import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render++-- $setup+-- >>> import Squeal.PostgreSQL++-- | The alias operator `:::` is like a promoted version of `As`,+-- a type level pair between an alias and some type.+type (:::) (alias :: Symbol) ty = '(alias,ty)+infixr 6 :::+++-- | `Grouping` is an auxiliary namespace, created by+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.groupBy`), and used+-- for typesafe aggregation+data Grouping+ = Ungrouped -- ^ no aggregation permitted+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped++{- | A `GroupedBy` constraint indicates that a table qualified column is+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.+-}+class (KnownSymbol table, KnownSymbol column)+ => GroupedBy table column bys where+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)+ => GroupedBy table column ('(table,column) ': bys)+instance {-# OVERLAPPABLE #-}+ ( KnownSymbol table+ , KnownSymbol column+ , GroupedBy table column bys+ ) => GroupedBy table column (tabcol ': bys)++-- | `Alias`es are proxies for a type level string or `Symbol`+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@+--+-- >>> :set -XOverloadedLabels+-- >>> #foobar :: Alias "foobar"+-- Alias+data Alias (alias :: Symbol) = Alias+ deriving (Eq,GHC.Generic,Ord,Show,NFData)+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where+ fromLabel = Alias+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where+ fromLabel = fromLabel SOP.:* Nil+-- | >>> printSQL (#jimbob :: Alias "jimbob")+-- "jimbob"+instance KnownSymbol alias => RenderSQL (Alias alias) where+ renderSQL = doubleQuoted . fromString . symbolVal++-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])+-- "jimbob", "kandi"+instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where+ renderSQL+ = commaSeparated+ . SOP.hcollapse+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)++-- | The `As` operator is used to name an expression. `As` is like a demoted+-- version of `:::`.+--+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)+-- As (Just "hello") Alias+data Aliased expression aliased where+ As+ :: KnownSymbol alias+ => expression ty+ -> Alias alias+ -> Aliased expression (alias ::: ty)+deriving instance Show (expression ty)+ => Show (Aliased expression (alias ::: ty))+deriving instance Eq (expression ty)+ => Eq (Aliased expression (alias ::: ty))+deriving instance Ord (expression ty)+ => Ord (Aliased expression (alias ::: ty))+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1++-- | The `Aliasable` class provides a way to scrap your `Nil`s+-- in an `NP` list of `Aliased` expressions.+class KnownSymbol alias => Aliasable alias expression aliased+ | aliased -> expression+ , aliased -> alias+ where as :: expression -> Alias alias -> aliased+instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias+ (expression ty)+ (Aliased expression aliased)+ where+ as = As+instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias+ (expression ty)+ (NP (Aliased expression) tys)+ where+ expression `as` alias = expression `As` alias SOP.:* Nil++-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")+-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)+-- "Just AS \"an_int\""+renderAliased+ :: (forall ty. expression ty -> ByteString)+ -> Aliased expression aliased+ -> ByteString+renderAliased render (expression `As` alias) =+ render expression <> " AS " <> renderSQL alias++-- | Map a function over an `Aliased` expression.+mapAliased+ :: (expr x -> expr y)+ -> Aliased expr (alias ::: x)+ -> Aliased expr (alias ::: y)+mapAliased f (x `As` alias) = f x `As` alias++-- | @HasUnique alias fields field@ is a constraint that proves that+-- @fields@ is a singleton of @alias ::: field@.+type HasUnique alias fields field = fields ~ '[alias ::: field]++-- | @Has alias fields field@ is a constraint that proves that+-- @fields@ has a field of @alias ::: field@, inferring @field@+-- from @alias@ and @fields@.+class (KnownSymbol alias) => Has (alias :: Symbol) (fields :: [(Symbol, kind)]) (field :: kind) | alias fields -> field+-- having these instances forces 'Has' to inspect 'alias' and 'fields' and thereby fail before delegating to+-- 'HasErr', which means 'Has' shows up in error messages instead of 'HasErr'+instance {-# OVERLAPPING #-} (KnownSymbol alias, HasErr (alias ::: field0 ': fields) alias (alias ::: field0 ': fields) field1)+ => Has alias (alias ::: field0 ': fields) field1+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr (field' ': fields) alias (field' ': fields) field)+ => Has alias (field' ': fields) field+instance (KnownSymbol alias, HasErr '[] alias '[] field)+ => Has alias '[] field++{- | 'HasErr' is like `Has` except it also retains the original+list of fields being searched, so that error messages are more+useful.+-}+class KnownSymbol alias =>+ HasErr (allFields :: [(Symbol, kind)]) (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)+ | alias fields -> field where+instance {-# OVERLAPPING #-} (KnownSymbol alias, field0 ~ field1, MismatchError alias allFields field0 field1)+ => HasErr allFields alias (alias ::: field0 ': fields) field1+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, HasErr allFields alias fields field)+ => HasErr allFields alias (field' ': fields) field+instance ( KnownSymbol alias+ , LookupFailedError alias allFields -- report a nicer error+ , field ~ Any -- required to satisfy the fundep+ ) => HasErr allFields alias '[] field++-- | @MismatchError@ reports a nicer error with more context when we successfully do a lookup but+-- find a different field than we expected. As a type family, it ensures that we only do the (expensive)+-- calculation of coming up with our pretty printing information when we actually have a mismatch+type family MismatchError (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where+ MismatchError _ _ found found = ()+ MismatchError alias fields found expected = MismatchError' (MismatchError' () (DefaultPrettyPrinter fields) alias fields found expected) (PrettyPrintHaystack fields) alias fields found expected++-- | @MismatchError'@ is the workhorse behind @MismatchError@, but taking an additional type as the first argument. We can put another type error+-- in there which will only show if @MismatchError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance+-- is missing+type family MismatchError' (err :: Constraint) (ppInfo :: PrettyPrintInfo) (alias :: Symbol) (fields :: [(Symbol, kind)]) (found :: kind) (expected :: kind) :: Constraint where+ MismatchError' _ ('PrettyPrintInfo needleName haystackName _) alias fields found expected = TypeError+ ( 'Text "Type mismatch when looking up " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType alias+ ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":"+ -- we don't use a pretty haystack because we want to show the values+ ':$$: 'ShowType fields+ ':$$: 'Text ""+ ':$$: 'Text "Expected: " ':<>: 'ShowType expected+ ':$$: 'Text "But found: " ':<>: 'ShowType found+ ':$$: 'Text ""+ )++-- | @LookupFailedError@ reports a nicer error when we fail to look up some @needle@ in some @haystack@+type LookupFailedError needle haystack = LookupFailedError' (LookupFailedError' () (DefaultPrettyPrinter haystack) needle haystack) (PrettyPrintHaystack haystack) needle haystack++-- | @LookupFailedError'@ is the workhorse behind @LookupFailedError@, but taking an additional type as the first argument. We can put another type error+-- in there which will only show if @LookupFailedError'@ is stuck; this allows us to fall back to @DefaultPrettyPrinter@ when a @PrettyPrintHaystack@ instance+-- is missing+type family LookupFailedError' (fallbackForUnknownKind :: Constraint) (prettyPrintInfo :: PrettyPrintInfo) (needle :: Symbol) (haystack :: [(Symbol, k)]) :: Constraint where+ LookupFailedError' _ ('PrettyPrintInfo needleName haystackName prettyHaystack) needle rawHaystack = TypeError+ ( 'Text "Could not find " ':<>: needleName ':<>: 'Text " named " ':<>: 'ShowType needle+ ':$$: 'Text "in " ':<>: haystackName ':<>: 'Text ":"+ ':$$: prettyHaystack+ ':$$: 'Text ""+ ':$$: 'Text "*Raw " ':<>: haystackName ':<>: 'Text "*:"+ ':$$: 'ShowType rawHaystack+ ':$$: 'Text ""+ )++-- | @PrettyPrintInfo@ is a data type intended to be used at the type level+-- which describes how to pretty print a haystack in our custom errors. The general intention is we use @PrettyPrintHaystack@+-- to define a more specific way of pretty printing our error information for each kind that we care about+data PrettyPrintInfo = PrettyPrintInfo+ { _needleName :: ErrorMessage+ , _haystackName :: ErrorMessage+ , _haystackPrettyPrint :: ErrorMessage+ }++-- | 'PrettyPrintHaystack' allows us to use the kind of our haystack to come up+-- with nicer errors. It is implemented as an open type family for dependency reasons+type family PrettyPrintHaystack (haystack :: [(Symbol, k)]) :: PrettyPrintInfo++-- | @DefaultPrettyPrinter@ provides a default we can use for kinds that don't provide an instance of @PrettyPrintInfo@,+-- although that should generally only be accidental+type family DefaultPrettyPrinter (haystack :: [(Symbol, k)]) :: PrettyPrintInfo where+ DefaultPrettyPrinter (haystack :: [(Symbol, k)]) = 'PrettyPrintInfo+ ('Text "some kind without a PrettyPrintHaystack instance (" ':<>: 'ShowType k ':<>: 'Text ")")+ ('Text "associative list of that kind ([(Symbol, " ':<>: 'ShowType k ':<>: 'Text ")])")+ ('ShowType (Sort (MapFst haystack)))++{-| @HasIn fields (alias ::: field)@ is a constraint that proves that+@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to+choose which subfields to update.+-}+class HasIn fields field where+instance (Has alias fields field) => HasIn fields (alias ::: field) where++-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer+-- a list of @subfields@.+class+ ( SOP.All KnownSymbol aliases+ ) => HasAll+ (aliases :: [Symbol])+ (fields :: [(Symbol,kind)])+ (subfields :: [(Symbol,kind)])+ | aliases fields -> subfields where+instance {-# OVERLAPPING #-} HasAll '[] fields '[]+instance {-# OVERLAPPABLE #-}+ (Has alias fields field, HasAll aliases fields subfields)+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)++-- | Analagous to `IsLabel`, the constraint+-- `IsQualified` defines `!` for a column alias qualified+-- by a table alias.+class IsQualified qualifier alias expression where+ (!) :: Alias qualifier -> Alias alias -> expression+ infixl 9 !+instance IsQualified qualifier alias (Alias qualifier, Alias alias) where+ (!) = (,)++{-| `QualifiedAlias`es enables multi-schema support by allowing a reference+to a `Squeal.PostgreSQL.Type.Schema.Table`, `Squeal.PostgreSQL.Type.Schema.Typedef`+or `Squeal.PostgreSQL.Type.Schema.View` to be qualified by their schemas. By default,+a qualifier of @public@ is provided.++>>> :{+let+ alias1 :: QualifiedAlias "sch" "tab"+ alias1 = #sch ! #tab+ alias2 :: QualifiedAlias "public" "vw"+ alias2 = #vw+in printSQL alias1 >> printSQL alias2+:}+"sch"."tab"+"vw"+-}+data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias+ deriving (Eq,GHC.Generic,Ord,Show,NFData)+instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where+ _ ! _ = QualifiedAlias+instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where+ fromLabel = QualifiedAlias+instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>+ IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where+ _ ! _ = QualifiedAlias `As` Alias+instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>+ IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where+ fromLabel = QualifiedAlias `As` Alias++instance (KnownSymbol q, KnownSymbol a)+ => RenderSQL (QualifiedAlias q a) where+ renderSQL _ =+ let+ qualifier = renderSQL (Alias @q)+ alias = renderSQL (Alias @a)+ in+ if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
+ src/Squeal/PostgreSQL/Type/List.hs view
@@ -0,0 +1,204 @@+{-|+Module: Squeal.PostgreSQL.Type.List+Description: list related types and functions+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Haskell singly-linked lists are very powerful. This module+provides functionality for type-level lists, heterogeneous+lists and type aligned lists.+-}++{-# LANGUAGE+ DataKinds+ , FlexibleContexts+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PolyKinds+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , UndecidableInstances+#-}++module Squeal.PostgreSQL.Type.List+ ( -- * Heterogeneous List+ SOP.NP (..)+ , (*:)+ , one+ -- * Path+ , Path (..)+ -- * Type Level List+ , Join+ , disjoin+ , Additional (..)+ , Elem+ , In+ , Length+ , SubList+ , SubsetList+ -- * Type Level Sort+ , Sort+ , MergeSort+ , Twos+ , FoldMerge+ , Merge+ , MergeHelper+ , MapFst+ ) where++import Control.Category.Free+import Data.Function ((&))+import Data.Kind+import Data.Type.Bool+import GHC.TypeLits++import Generics.SOP as SOP++-- | `Join` is simply promoted `++` and is used in @JOIN@s in+-- `Squeal.PostgreSQL.Query.FromClause`s.+type family Join xs ys where+ Join '[] ys = ys+ Join (x ': xs) ys = x ': Join xs ys++-- | `disjoin` is a utility function for splitting an `NP` list into pieces.+disjoin+ :: forall xs ys expr. SListI xs+ => NP expr (Join xs ys)+ -> (NP expr xs, NP expr ys)+disjoin = case sList @xs of+ SNil -> \ys -> (Nil, ys)+ SCons -> \(x :* xsys) ->+ case disjoin xsys of (xs,ys) -> (x :* xs, ys)++-- | The `Additional` class is for appending+-- type-level list parameterized constructors such as `NP`,+-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.+class Additional expr where+ also :: expr ys -> expr xs -> expr (Join xs ys)+instance Additional (NP expr) where+ also ys = \case+ Nil -> ys+ x :* xs -> x :* (xs & also ys)++-- | A useful operator for ending an `NP` list of length+-- at least 2 without `Nil`+(*:) :: f x -> f y -> NP f '[x,y]+x *: y = x :* y :* Nil+infixl 8 *:++-- | A list of length `one`.+one :: f x -> NP f '[x]+one f = f :* Nil++-- | @Elem@ is a promoted `Data.List.elem`.+type family Elem x xs where+ Elem x '[] = 'False+ Elem x (x ': _) = 'True+ Elem x (_ ': xs) = Elem x xs++-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.+type family In x xs :: Constraint where+ In x xs = If (Elem x xs) (() :: Constraint)+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))++{- | Calculate the `Length` of a type level list++>>> :kind! Length '[Char,String,Bool,Double]+Length '[Char,String,Bool,Double] :: Nat+= 4+-}+type family Length (xs :: [k]) :: Nat where+ Length '[] = 0+ Length (_ : xs) = 1 + Length xs++{- | `SubList` checks that one type level list is a sublist of another,+with the same ordering.++>>> :kind! SubList '[1,2,3] '[4,5,6]+SubList '[1,2,3] '[4,5,6] :: Bool+= 'False+>>> :kind! SubList '[1,2,3] '[1,2,3,4]+SubList '[1,2,3] '[1,2,3,4] :: Bool+= 'True+>>> :kind! SubList '[1,2,3] '[0,1,0,2,0,3]+SubList '[1,2,3] '[0,1,0,2,0,3] :: Bool+= 'True+>>> :kind! SubList '[1,2,3] '[3,2,1]+SubList '[1,2,3] '[3,2,1] :: Bool+= 'False+-}+type family SubList (xs :: [k]) (ys :: [k]) :: Bool where+ SubList '[] ys = 'True+ SubList (x ': xs) '[] = 'False+ SubList (x ': xs) (x ': ys) = SubList xs ys+ SubList (x ': xs) (y ': ys) = SubList (x ': xs) ys++{- | `SubsetList` checks that one type level list is a subset of another,+regardless of ordering and repeats.++>>> :kind! SubsetList '[1,2,3] '[4,5,6]+SubsetList '[1,2,3] '[4,5,6] :: Bool+= 'False+>>> :kind! SubsetList '[1,2,3] '[1,2,3,4]+SubsetList '[1,2,3] '[1,2,3,4] :: Bool+= 'True+>>> :kind! SubsetList '[1,2,3] '[0,1,0,2,0,3]+SubsetList '[1,2,3] '[0,1,0,2,0,3] :: Bool+= 'True+>>> :kind! SubsetList '[1,2,3] '[3,2,1]+SubsetList '[1,2,3] '[3,2,1] :: Bool+= 'True+>>> :kind! SubsetList '[1,1,1] '[3,2,1]+SubsetList '[1,1,1] '[3,2,1] :: Bool+= 'True+-}+type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where+ SubsetList '[] ys = 'True+ SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys++-- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order+type Sort ls = MergeSort (Twos ls)++-- | 'MergeSort' is the workhorse behind 'Sort'+type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where+ MergeSort '[] = '[]+ MergeSort '[x] = x+ MergeSort ls = MergeSort (FoldMerge ls)++-- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end)+-- It is required for implementing 'MergeSort'+type family Twos (ls :: [k]) :: [[k]] where+ Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs+ Twos '[x] = '[ '[x]]+ Twos '[] = '[]++-- | 'Merge' two sorted lists into one list+type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where+ Merge '[] r = r+ Merge l '[] = l+ Merge (l ': ls) (r ': rs) = MergeHelper (l ': ls) (r ': rs) (CmpSymbol l r)++-- | 'MergeHelper' decides whether to take an element from the right or left list next,+-- depending on the result of their comparison+type family MergeHelper (ls :: [Symbol]) (rs :: [Symbol]) (cmp :: Ordering) where+ MergeHelper ls (r ': rs) 'GT = r ': Merge ls rs+ MergeHelper (l ': ls) rs leq = l ': Merge ls rs++-- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list+type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where+ FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs)+ FoldMerge '[x] = '[x]+ FoldMerge '[] = '[]++-- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting+-- only the names in associatve lists+type family MapFst (ls :: [(j, k)]) :: [j] where+ MapFst ('(j, _) ': rest) = j ': MapFst rest+ MapFst '[] = '[]
+ src/Squeal/PostgreSQL/Type/PG.hs view
@@ -0,0 +1,346 @@+{-|+Module: Squeal.PostgreSQL.Type.PG+Description: embedding of Haskell types into Postgres type system+Copyright: (c) Eitan Chatav, 2010+Maintainer: eitan@morphism.tech+Stability: experimental++Provides type families for turning Haskell `Type`s+into corresponding Postgres types.+-}+{-# LANGUAGE+ AllowAmbiguousTypes+ , CPP+ , DeriveAnyClass+ , DeriveFoldable+ , DeriveFunctor+ , DeriveGeneric+ , DeriveTraversable+ , DerivingStrategies+ , DefaultSignatures+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Type.PG+ ( -- * PG+ IsPG (..)+ , NullPG+ , TuplePG+ , RowPG+ -- * Type families+ , LabelsPG+ , DimPG+ , FixPG+ , TupleOf+ , TupleCodeOf+ , RowOf+ , ConstructorsOf+ , ConstructorNameOf+ , ConstructorNamesOf+ ) where++import Data.Aeson (Value)+import Data.Functor.Const (Const)+import Data.Functor.Constant (Constant)+import Data.Kind (Type)+import Data.Int (Int16, Int32, Int64)+#if MIN_VERSION_postgresql_binary(0, 14, 0)+import Data.IP (IPRange)+#else+import Network.IP.Addr (NetAddr, IP)+#endif+import Data.Scientific (Scientific)+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)+import Data.Vector (Vector)+import Data.UUID.Types (UUID)+import GHC.TypeLits++import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.Text.Lazy as Lazy (Text)+import qualified Data.Text as Strict (Text)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Generics.SOP as SOP+import qualified Generics.SOP.Record as SOP+import qualified Generics.SOP.Type.Metadata as Type++import Squeal.PostgreSQL.Type+import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.Schema++-- $setup+-- >>> import Squeal.PostgreSQL+-- >>> import Data.Text (Text)+-- >>> import qualified GHC.Generics as GHC++{- | The `PG` type family embeds a subset of Haskell types+as Postgres types. As an open type family, `PG` is extensible.++>>> :kind! PG LocalTime+PG LocalTime :: PGType+= 'PGtimestamp++The preferred way to generate `PG`s of your own type is through+generalized newtype deriving or via deriving.++>>> newtype UserId = UserId {getUserId :: UUID} deriving newtype IsPG++>>> :kind! PG UserId+PG UserId :: PGType+= 'PGuuid++>>> :{+data Answer = Yes | No+ deriving stock GHC.Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving IsPG via Enumerated Answer+:}++>>> :kind! PG Answer+PG Answer :: PGType+= 'PGenum '["Yes", "No"]++>>> :{+data Complex = Complex {real :: Double, imaginary :: Double}+ deriving stock GHC.Generic+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving IsPG via Composite Complex+:}++>>> :kind! PG Complex+PG Complex :: PGType+= 'PGcomposite+ '["real" ::: 'NotNull 'PGfloat8,+ "imaginary" ::: 'NotNull 'PGfloat8]+-}+class IsPG (hask :: Type) where type PG hask :: PGType+-- | `PGbool`+instance IsPG Bool where type PG Bool = 'PGbool+-- | `PGint2`+instance IsPG Int16 where type PG Int16 = 'PGint2+-- | `PGint4`+instance IsPG Int32 where type PG Int32 = 'PGint4+-- | `PGint8`+instance IsPG Int64 where type PG Int64 = 'PGint8+-- | `PGint2`+instance IsPG LibPQ.Oid where type PG LibPQ.Oid = 'PGoid+-- | `PGnumeric`+instance IsPG Scientific where type PG Scientific = 'PGnumeric+-- | `PGfloat4`+instance IsPG Float where type PG Float = 'PGfloat4+-- | `PGfloat8`+instance IsPG Double where type PG Double = 'PGfloat8+-- | `PGchar` @1@+instance IsPG Char where type PG Char = 'PGchar 1+-- | `PGtext`+instance IsPG Strict.Text where type PG Strict.Text = 'PGtext+-- | `PGtext`+instance IsPG Lazy.Text where type PG Lazy.Text = 'PGtext+-- | `PGtext`+instance IsPG String where type PG String = 'PGtext+-- | `PGbytea`+instance IsPG Strict.ByteString where type PG Strict.ByteString = 'PGbytea+-- | `PGbytea`+instance IsPG Lazy.ByteString where type PG Lazy.ByteString = 'PGbytea+-- | `PGtimestamp`+instance IsPG LocalTime where type PG LocalTime = 'PGtimestamp+-- | `PGtimestamptz`+instance IsPG UTCTime where type PG UTCTime = 'PGtimestamptz+-- | `PGdate`+instance IsPG Day where type PG Day = 'PGdate+-- | `PGtime`+instance IsPG TimeOfDay where type PG TimeOfDay = 'PGtime+-- | `PGtimetz`+instance IsPG (TimeOfDay, TimeZone) where type PG (TimeOfDay, TimeZone) = 'PGtimetz+-- | `PGinterval`+instance IsPG DiffTime where type PG DiffTime = 'PGinterval+-- | `PGuuid`+instance IsPG UUID where type PG UUID = 'PGuuid+-- | `PGinet`+#if MIN_VERSION_postgresql_binary(0, 14, 0)+instance IsPG IPRange where type PG IPRange = 'PGinet+#else+instance IsPG (NetAddr IP) where type PG (NetAddr IP) = 'PGinet+#endif+-- | `PGjson`+instance IsPG Value where type PG Value = 'PGjson+-- | `PGvarchar`+instance IsPG (VarChar n) where type PG (VarChar n) = 'PGvarchar n+-- | `PGvarchar`+instance IsPG (FixChar n) where type PG (FixChar n) = 'PGchar n+-- | `PG hask`+instance IsPG hask => IsPG (Const hask tag) where type PG (Const hask tag) = PG hask+-- | `PG hask`+instance IsPG hask => IsPG (SOP.K hask tag) where type PG (SOP.K hask tag) = PG hask+-- | `PG hask`+instance IsPG hask => IsPG (Constant hask tag) where type PG (Constant hask tag) = PG hask++-- | `PGmoney`+instance IsPG Money where type PG Money = 'PGmoney+-- | `PGjson`+instance IsPG (Json hask) where type PG (Json hask) = 'PGjson+-- | `PGjsonb`+instance IsPG (Jsonb hask) where type PG (Jsonb hask) = 'PGjsonb+-- | `PGcomposite` @(@`RowPG` @hask)@+instance IsPG (Composite hask) where+ type PG (Composite hask) = 'PGcomposite (RowPG hask)+-- | `PGenum` @(@`LabelsPG` @hask)@+instance IsPG (Enumerated hask) where+ type PG (Enumerated hask) = 'PGenum (LabelsPG hask)+-- | `PGvararray` @(@`NullPG` @x)@+instance IsPG (VarArray (Vector x)) where+ type PG (VarArray (Vector x)) = 'PGvararray (NullPG x)+-- | `PGvararray` @(@`NullPG` @x)@+instance IsPG (VarArray [x]) where+ type PG (VarArray [x]) = 'PGvararray (NullPG x)+-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@+instance IsPG (FixArray hask) where+ type PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)++{-| The `LabelsPG` type family calculates the constructors of a+Haskell enum type.++>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic+>>> instance SOP.Generic Schwarma+>>> instance SOP.HasDatatypeInfo Schwarma+>>> :kind! LabelsPG Schwarma+LabelsPG Schwarma :: [Type.ConstructorName]+= '["Beef", "Lamb", "Chicken"]+-}+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where+ LabelsPG hask =+ ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))++{- |+`RowPG` turns a Haskell `Type` into a `RowType`.++`RowPG` may be applied to normal Haskell record types provided they+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;++>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic+>>> instance SOP.Generic Person+>>> instance SOP.HasDatatypeInfo Person+>>> :kind! RowPG Person+RowPG Person :: [(Symbol, NullType)]+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]+-}+type family RowPG (hask :: Type) :: RowType where+ RowPG hask = RowOf (SOP.RecordCodeOf hask)++-- | `RowOf` applies `NullPG` to the fields of a list.+type family RowOf (record :: [(Symbol, Type)]) :: RowType where+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record+ RowOf '[] = '[]++{- | `NullPG` turns a Haskell type into a `NullType`.++>>> :kind! NullPG Double+NullPG Double :: NullType+= 'NotNull 'PGfloat8+>>> :kind! NullPG (Maybe Double)+NullPG (Maybe Double) :: NullType+= 'Null 'PGfloat8+-}+type family NullPG (hask :: Type) :: NullType where+ NullPG (Maybe hask) = 'Null (PG hask)+ NullPG hask = 'NotNull (PG hask)++{- | `TuplePG` turns a Haskell tuple type (including record types) into+the corresponding list of `NullType`s.++>>> :kind! TuplePG (Double, Maybe Char)+TuplePG (Double, Maybe Char) :: [NullType]+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]+-}+type family TuplePG (hask :: Type) :: [NullType] where+ TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))++-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullType`s.+type family TupleOf (tuple :: [Type]) :: [NullType] where+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple+ TupleOf '[] = '[]++-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`+-- and if it's a simple product returns it, otherwise giving a `TypeError`.+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where+ TupleCodeOf hask '[tuple] = tuple+ TupleCodeOf hask '[] =+ TypeError+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."+ ':$$: 'Text "It is a void type with no constructors."+ )+ TupleCodeOf hask (_ ': _ ': _) =+ TypeError+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."+ ':$$: 'Text "It is a sum type with more than one constructor."+ )++-- | Calculates constructors of a datatype.+type family ConstructorsOf (datatype :: Type.DatatypeInfo)+ :: [Type.ConstructorInfo] where+ ConstructorsOf ('Type.ADT _module _datatype constructors _strictness) =+ constructors+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =+ '[constructor]++-- | Calculates the name of a nullary constructor, otherwise+-- generates a type error.+type family ConstructorNameOf (constructor :: Type.ConstructorInfo)+ :: Type.ConstructorName where+ ConstructorNameOf ('Type.Constructor name) = name+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError+ ('Text "ConstructorNameOf error: non-nullary constructor "+ ':<>: 'Text name)+ ConstructorNameOf ('Type.Record name _fields) = TypeError+ ('Text "ConstructorNameOf error: non-nullary constructor "+ ':<>: 'Text name)++-- | Calculate the names of nullary constructors.+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])+ :: [Type.ConstructorName] where+ ConstructorNamesOf '[] = '[]+ ConstructorNamesOf (constructor ': constructors) =+ ConstructorNameOf constructor ': ConstructorNamesOf constructors++-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths,+-- up to a depth of 10 for each dimension.+type family DimPG (hask :: Type) :: [Nat] where+ DimPG (x,x) = 2 ': DimPG x+ DimPG (x,x,x) = 3 ': DimPG x+ DimPG (x,x,x,x) = 4 ': DimPG x+ DimPG (x,x,x,x,x) = 5 ': DimPG x+ DimPG (x,x,x,x,x,x) = 6 ': DimPG x+ DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x+ DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x+ DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x+ DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x+ DimPG x = '[]++-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples,+-- up to a depth of 10 for each dimension.+type family FixPG (hask :: Type) :: NullType where+ FixPG (x,x) = FixPG x+ FixPG (x,x,x) = FixPG x+ FixPG (x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x+ FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x+ FixPG x = NullPG x
+ src/Squeal/PostgreSQL/Type/Schema.hs view
@@ -0,0 +1,842 @@+{-|+Module: Squeal.PostgreSQL.Type.Schema+Description: Postgres type system+Copyright: (c) Eitan Chatav, 2019+Maintainer: eitan@morphism.tech+Stability: experimental++Provides a type-level DSL for kinds of Postgres types,+tables, schema, constraints, and more.+It also defines useful type families to operate on these.+-}++{-# LANGUAGE+ AllowAmbiguousTypes+ , ConstraintKinds+ , DeriveAnyClass+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , LambdaCase+ , OverloadedStrings+ , QuantifiedConstraints+ , RankNTypes+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilyDependencies+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+ , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Type.Schema+ ( -- * Postgres Type+ PGType (..)+ , NullType (..)+ , RowType+ , FromType+ -- * Schema Type+ , ColumnType+ , ColumnsType+ , TableType+ , SchemumType (..)+ , IndexType (..)+ , FunctionType+ , ReturnsType (..)+ , SchemaType+ , SchemasType+ , Public+ -- * Database Subsets+ , SubDB+ , SubsetDB+ , ElemDB+ -- * Constraint+ , (:=>)+ , Optionality (..)+ , TableConstraint (..)+ , TableConstraints+ , Uniquely+ -- * Enumerated Label+ , IsPGlabel (..)+ , PGlabel (..)+ -- * Data Definition+ , Create+ , CreateIfNotExists+ , CreateOrReplace+ , Drop+ , DropSchemum+ , DropIfExists+ , DropSchemumIfExists+ , Alter+ , AlterIfExists+ , Rename+ , RenameIfExists+ , SetSchema+ , ConstraintInvolves+ , DropIfConstraintsInvolve+ -- * Type Classification+ , PGNum+ , PGIntegral+ , PGFloating+ , PGJsonType+ , PGJsonKey+ , SamePGType+ , AllNotNull+ , NotAllNull+ -- * Nullification+ , NullifyType+ , NullifyRow+ , NullifyFrom+ -- * Table Conversion+ , TableToColumns+ , ColumnsToRow+ , TableToRow+ -- * Updatable+ , Updatable+ , AllUnique+ , IsNotElem+ -- * User Type Lookup+ , DbEnums+ , SchemaEnums+ , DbRelations+ , SchemaRelations+ , FindQualified+ , FindName+ , FindNamespace+ -- * Schema Error Printing+ , PrettyPrintPartitionedSchema+ , PartitionedSchema(..)+ , PartitionSchema+ , SchemaFunctions+ , SchemaIndexes+ , SchemaProcedures+ , SchemaTables+ , SchemaTypes+ , SchemaUnsafes+ , SchemaViews+ , IntersperseNewlines+ , FilterNonEmpty+ , FieldIfNonEmpty+ , PartitionSchema'+ ) where++import Control.Category+import Data.Kind+import Data.Monoid hiding (All)+import Data.Type.Bool+import Generics.SOP+import GHC.TypeLits+import Prelude hiding (id, (.))++import Squeal.PostgreSQL.Type.Alias+import Squeal.PostgreSQL.Type.List+import Squeal.PostgreSQL.Render++-- $setup+-- >>> import Squeal.PostgreSQL++-- | `PGType` is the promoted datakind of PostgreSQL types.+--+-- >>> :kind 'PGbool+-- 'PGbool :: PGType+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)+ | PGmoney -- ^ currency amount+ | 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+ | PGvararray NullType -- ^ variable length array+ | PGfixarray [Nat] NullType -- ^ fixed length array+ | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.+ | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.+ | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.+ | PGoid -- ^ Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.+ | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).+ | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types++-- | `NullType` encodes the potential presence or definite absence of a+-- @NULL@ allowing operations which are sensitive to such to be well typed.+--+-- >>> :kind 'Null 'PGint4+-- 'Null 'PGint4 :: NullType+-- >>> :kind 'NotNull ('PGvarchar 50)+-- 'NotNull ('PGvarchar 50) :: NullType+data NullType+ = Null PGType -- ^ @NULL@ may be present+ | NotNull PGType -- ^ @NULL@ is absent++-- | The constraint operator, `:=>` is a type level pair+-- between a "constraint" and some type, for use in pairing+-- an `Optionality` with a `NullType` to produce a `ColumnType`+-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.+type (:=>) constraint ty = '(constraint,ty)+infixr 7 :=>++-- | `Optionality` encodes the availability of @DEFAULT@ for inserts and updates.+-- A column can be assigned a default value.+-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also+-- request explicitly that a column be set to its default value,+-- without having to know what that value is.+data Optionality+ = Def -- ^ @DEFAULT@ is available for inserts and updates+ | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates++-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the+-- base `PGType` for a column.+--+-- >>> :set -XTypeFamilies -XDataKinds -XPolyKinds+-- >>> import GHC.TypeLits+-- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4+-- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext+type ColumnType = (Optionality,NullType)++-- | `ColumnsType` is a row of `ColumnType`s.+--+-- >>> :{+-- type family UsersColumns :: ColumnsType where+-- UsersColumns =+-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext+-- , "id" ::: 'Def :=> 'NotNull 'PGint4+-- ]+-- :}+type ColumnsType = [(Symbol,ColumnType)]++type instance PrettyPrintHaystack (haystack :: ColumnsType) =+ 'PrettyPrintInfo ('Text "column definition (ColumnType)") ('Text "table (ColumnsType)") ('ShowType (Sort (MapFst haystack)))++-- | `TableConstraint` encodes various forms of data constraints+-- of columns in a table.+-- `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.+data TableConstraint+ = Check [Symbol]+ | Unique [Symbol]+ | PrimaryKey [Symbol]+ | ForeignKey [Symbol] Symbol Symbol [Symbol]++{- | A `TableConstraints` is a row of `TableConstraint`s.++>>> :{+type family UsersConstraints :: TableConstraints where+ UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]+:}+-}+type TableConstraints = [(Symbol,TableConstraint)]++type instance PrettyPrintHaystack (haystack :: TableConstraints) =+ 'PrettyPrintInfo ('Text "constraint (TableConstraint)") ('Text "table (TableConstraints)") ('ShowType (Sort (MapFst haystack)))++-- | A `ForeignKey` must reference columns that either are+-- a `PrimaryKey` or form a `Unique` constraint.+type family Uniquely+ (key :: [Symbol])+ (constraints :: TableConstraints) :: Constraint where+ Uniquely key (uq ::: 'Unique key ': constraints) = ()+ Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()+ Uniquely key (_ ': constraints) = Uniquely key constraints++-- | `TableType` encodes a row of constraints on a table as well as the types+-- of its columns.+--+-- >>> :{+-- type family UsersTable :: TableType where+-- UsersTable =+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext+-- ]+-- :}+type TableType = (TableConstraints,ColumnsType)++{- | A `RowType` is a row of `NullType`s. They correspond to Haskell+record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.++>>> :{+type family PersonRow :: RowType where+ PersonRow =+ '[ "name" ::: 'NotNull 'PGtext+ , "age" ::: 'NotNull 'PGint4+ , "dateOfBirth" ::: 'Null 'PGdate+ ]+:}+-}+type RowType = [(Symbol,NullType)]++type instance PrettyPrintHaystack (haystack :: RowType) =+ 'PrettyPrintInfo ('Text "column (NullType)") ('Text "row (RowType)") ('ShowType (Sort (MapFst haystack)))++{- | `FromType` is a row of `RowType`s. It can be thought of as+a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.From.FromClause`s+and `Squeal.PostgreSQL.Query.Table.TableExpression`s.+-}+type FromType = [(Symbol,RowType)]++type instance PrettyPrintHaystack (haystack :: FromType) =+ 'PrettyPrintInfo ('Text "row (RowType)") ('Text "from clause (FromType)") ('ShowType (Sort (MapFst haystack)))++-- | `ColumnsToRow` removes column constraints.+type family ColumnsToRow (columns :: ColumnsType) :: RowType where+ ColumnsToRow (column ::: _ :=> ty ': columns) =+ column ::: ty ': ColumnsToRow columns+ ColumnsToRow '[] = '[]++-- | `TableToColumns` removes table constraints.+type family TableToColumns (table :: TableType) :: ColumnsType where+ TableToColumns (constraints :=> columns) = columns++-- | Convert a table to a row type.+type family TableToRow (table :: TableType) :: RowType where+ TableToRow tab = ColumnsToRow (TableToColumns tab)++-- | Numeric Postgres types.+type PGNum =+ '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]++-- | Floating Postgres types.+type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]++-- | Integral Postgres types.+type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]++-- | Equality constraint on the underlying `PGType` of two columns.+class SamePGType+ (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where+instance ty0 ~ ty1 => SamePGType+ (alias0 ::: def0 :=> null0 ty0)+ (alias1 ::: def1 :=> null1 ty1)++-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.+type family AllNotNull (columns :: ColumnsType) :: Constraint where+ AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns+ AllNotNull '[] = ()++-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some+-- @NOT NULL@.+type family NotAllNull (columns :: ColumnsType) :: Constraint where+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns++-- | `NullifyType` is an idempotent that nullifies a `NullType`.+type family NullifyType (ty :: NullType) :: NullType where+ NullifyType (null ty) = 'Null ty++-- | `NullifyRow` is an idempotent that nullifies a `RowType`.+type family NullifyRow (columns :: RowType) :: RowType where+ NullifyRow (column ::: ty ': columns) =+ column ::: NullifyType ty ': NullifyRow columns+ NullifyRow '[] = '[]++-- | `NullifyFrom` is an idempotent that nullifies a `FromType`+-- used to nullify the left or right hand side of an outer join+-- in a `Squeal.PostgreSQL.Query.From.FromClause`.+type family NullifyFrom (tables :: FromType) :: FromType where+ NullifyFrom (table ::: columns ': tables) =+ table ::: NullifyRow columns ': NullifyFrom tables+ NullifyFrom '[] = '[]++-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in+-- `Squeal.PostgreSQL.Definition.Table.createTable` statements and in @ALTER TABLE@+-- `Squeal.PostgreSQL.Definition.Table.addColumn`.+type family Create alias x xs where+ Create alias x '[] = '[alias ::: x]+ Create alias x (alias ::: y ': xs) = TypeError+ ('Text "Create: alias "+ ':<>: 'ShowType alias+ ':<>: 'Text "already exists")+ Create alias y (x ': xs) = x ': Create alias y xs++{-| Similar to `Create` but no error on pre-existence-}+type family CreateIfNotExists alias x xs where+ CreateIfNotExists alias x '[] = '[alias ::: x]+ CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs+ CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs++{-| Similar to `Create` but used to replace values+with the same type.-}+type family CreateOrReplace alias x xs where+ CreateOrReplace alias x '[] = '[alias ::: x]+ CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs+ CreateOrReplace alias x (alias ::: y ': xs) = TypeError+ ('Text "CreateOrReplace: expected type "+ ':<>: 'ShowType x+ ':<>: 'Text " but alias "+ ':<>: 'ShowType alias+ ':<>: 'Text " has type "+ ':<>: 'ShowType y)+ CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace 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 '[] = TypeError+ ('Text "Drop: alias "+ ':<>: 'ShowType alias+ ':<>: 'Text " does not exist" )+ Drop alias (alias ::: x ': xs) = xs+ Drop alias (x ': xs) = x ': Drop alias xs++-- | Drop a particular flavor of schemum type+type family DropSchemum alias sch xs where+ DropSchemum alias sch '[] = TypeError+ ('Text "DropSchemum: alias "+ ':<>: 'ShowType alias+ ':<>: 'Text " does not exist" )+ DropSchemum alias sch (alias ::: sch x ': xs) = xs+ DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError+ ('Text "DropSchemum: expected schemum "+ ':<>: 'ShowType sch0+ ':<>: 'Text " but alias "+ ':<>: 'ShowType alias+ ':<>: 'Text " has schemum "+ ':<>: 'ShowType sch1)+ DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs++-- | Similar to `Drop` but no error on non-existence+type family DropIfExists alias xs where+ DropIfExists alias '[] = '[]+ DropIfExists alias (alias ::: x ': xs) = xs+ DropIfExists alias (x ': xs) = x ': DropIfExists alias xs++-- | Similar to `DropSchemum` but no error on non-existence+type family DropSchemumIfExists alias sch xs where+ DropSchemumIfExists alias sch '[] = '[]+ DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs+ DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError+ ('Text "DropSchemumIfExists: expected schemum "+ ':<>: 'ShowType sch1+ ':<>: 'Text " but alias "+ ':<>: 'ShowType alias+ ':<>: 'Text " has schemum "+ ':<>: 'ShowType sch0)+ DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs++-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@+-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`+-- and `Squeal.PostgreSQL.Definition.alterColumn`.+type family Alter alias x xs where+ Alter alias x '[] = TypeError+ ('Text "Alter: alias "+ ':<>: 'ShowType alias+ ':<>: 'Text " does not exist" )+ Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs+ Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs++-- | Similar to `Alter` but no error on non-existence+type family AlterIfExists alias x xs where+ AlterIfExists alias x '[] = '[]+ AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs+ AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs++-- | @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 '[] = TypeError+ ('Text "Rename: alias "+ ':<>: 'ShowType alias0+ ':<>: 'Text " does not exist" )+ Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs+ Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs++-- | Similar to `Rename` but no error on non-existence+type family RenameIfExists alias0 alias1 xs where+ RenameIfExists alias x '[] = '[]+ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs+ RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs++-- | Move an object from one schema to another+type family SetSchema sch0 sch1 schema0 schema1 obj srt ty db where+ SetSchema sch0 sch1 schema0 schema1 obj srt ty db = Alter sch1+ (Create obj (srt ty) schema1)+ (Alter sch0 (DropSchemum obj srt schema0) db)++{- | `SubDB` checks that one `SchemasType` is a sublist of another,+with the same ordering.++>>> :kind! SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]]+SubDB '["a" ::: '["b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4]] :: Bool+= 'True+-}+type family SubDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where+ SubDB '[] db1 = 'True+ SubDB (sch ': db0) '[] = 'False+ SubDB (sch ::: schema0 ': db0) (sch ::: schema1 ': db1) =+ If (SubList schema0 schema1)+ (SubDB db0 db1)+ (SubDB (sch ::: schema0 ': db0) db1)+ SubDB db0 (sch1 ': db1) = SubDB db0 db1++{- | `SubsetDB` checks that one `SchemasType` is a subset of another,+regardless of ordering.++>>> :kind! SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]]+SubsetDB '["a" ::: '["d" ::: 'Typedef 'PGint2, "b" ::: 'View '[]]] '["a" ::: '["b" ::: 'View '[], "c" ::: 'Typedef 'PGint4, "d" ::: 'Typedef 'PGint2]] :: Bool+= 'True+-}+type family SubsetDB (db0 :: SchemasType) (db1 :: SchemasType) :: Bool where+ SubsetDB '[] db1 = 'True+ SubsetDB (sch ': db0) db1 = ElemDB sch db1 && SubsetDB db0 db1++{- | `ElemDB` checks that a schema may be found as a subset of another in a database,+regardless of ordering.+-}+type family ElemDB (sch :: (Symbol, SchemaType)) (db :: SchemasType) :: Bool where+ ElemDB sch '[] = 'False+ ElemDB (sch ::: schema0) (sch ::: schema1 ': _) = SubsetList schema0 schema1+ ElemDB sch (_ ': schs) = ElemDB sch schs++-- | Check if a `TableConstraint` involves a column+type family ConstraintInvolves column constraint where+ ConstraintInvolves column ('Check columns) = column `Elem` columns+ ConstraintInvolves column ('Unique columns) = column `Elem` columns+ ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns+ ConstraintInvolves column ('ForeignKey columns sch tab refcolumns)+ = column `Elem` columns++-- | Drop all `TableConstraint`s that involve a column+type family DropIfConstraintsInvolve column constraints where+ DropIfConstraintsInvolve column '[] = '[]+ DropIfConstraintsInvolve column (alias ::: constraint ': constraints)+ = If (ConstraintInvolves column constraint)+ (DropIfConstraintsInvolve column constraints)+ (alias ::: constraint ': DropIfConstraintsInvolve column constraints)++-- | A `SchemumType` is a user-created type, like a `Table`,+-- `View` or `Typedef`.+data SchemumType+ = Table TableType+ | View RowType+ | Typedef PGType+ | Index IndexType+ | Function FunctionType+ | Procedure [NullType]+ | UnsafeSchemum Symbol++{- | Use `:=>` to pair the parameter types with the return+type of a function.++>>> :{+type family Fn :: FunctionType where+ Fn = '[ 'NotNull 'PGint4] :=> 'Returns ('NotNull 'PGint4)+:}+-}+type FunctionType = ([NullType], ReturnsType)++{- |+PostgreSQL provides several index types:+B-tree, Hash, GiST, SP-GiST, GIN and BRIN.+Each index type uses a different algorithm+that is best suited to different types of queries.+-}+data IndexType+ = Btree+ -- ^ B-trees can handle equality and range queries on data+ -- that can be sorted into some ordering.+ | Hash+ -- ^ Hash indexes can only handle simple equality comparisons.+ | Gist+ -- ^ GiST indexes are not a single kind of index,+ -- but rather an infrastructure within which many different+ -- indexing strategies can be implemented.+ | Spgist+ -- ^ SP-GiST indexes, like GiST indexes,+ -- offer an infrastructure that supports various kinds of searches.+ | Gin+ -- ^ GIN indexes are “inverted indexes” which are appropriate for+ -- data values that contain multiple component values, such as arrays.+ | Brin+ -- ^ BRIN indexes (a shorthand for Block Range INdexes) store summaries+ -- about the values stored in consecutive physical block ranges of a table.++{- | Return type of a function-}+data ReturnsType+ = Returns NullType -- ^ function+ | ReturnsTable RowType -- ^ set returning function++{- | A schema of a database consists of a list of aliased,+user-defined `SchemumType`s.++>>> :{+type family Schema :: SchemaType where+ Schema =+ '[ "users" ::: 'Table (+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ ])+ , "emails" ::: 'Table (+ '[ "pk_emails" ::: 'PrimaryKey '["id"]+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"]+ ] :=>+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4+ , "email" ::: 'NoDef :=> 'Null 'PGtext+ ])+ ]+:}+-}+type SchemaType = [(Symbol,SchemumType)]++-- | A @PartitionedSchema@ is a @SchemaType@ where each constructor of @SchemumType@ has+-- been separated into its own list+data PartitionedSchema = PartitionedSchema+ { _tables :: [(Symbol, TableType)]+ , _views :: [(Symbol, RowType)]+ , _types :: [(Symbol, PGType)]+ , _indexes :: [(Symbol, IndexType)]+ , _functions :: [(Symbol, FunctionType)]+ , _procedures :: [(Symbol, [NullType])]+ , _unsafes :: [(Symbol, Symbol)]+ }++-- | @PartitionSchema@ partitions a @SchemaType@ into a @PartitionedSchema@+type PartitionSchema schema = PartitionSchema' schema ('PartitionedSchema '[] '[] '[] '[] '[] '[] '[])++-- | Utility type family for `PartitionSchema`.+type family PartitionSchema' (remaining :: SchemaType) (acc :: PartitionedSchema) :: PartitionedSchema where+ PartitionSchema' '[] ps = ps+ PartitionSchema' ('(s, 'Table table) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema ('(s, table) ': tables) views types indexes functions procedures unsafe)+ PartitionSchema' ('(s, 'View view) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema tables ('(s, view) ': views) types indexes functions procedures unsafe)+ PartitionSchema' ('(s, 'Typedef typ) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema tables views ('(s, typ) ': types) indexes functions procedures unsafe)+ PartitionSchema' ('(s, 'Index ix) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema tables views types ('(s, ix) ': indexes) functions procedures unsafe)+ PartitionSchema' ('(s, 'Function f) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema tables views types indexes ('(s, f) ': functions) procedures unsafe)+ PartitionSchema' ('(s, 'Procedure p) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions ('(s, p) ': procedures) unsafe)+ PartitionSchema' ('(s, 'UnsafeSchemum u) ': rest) ('PartitionedSchema tables views types indexes functions procedures unsafe)+ = PartitionSchema' rest ('PartitionedSchema tables views types indexes functions procedures ('(s, u) ': unsafe))++-- | Get the tables from a @PartitionedSchema@+type family SchemaTables (schema :: PartitionedSchema) :: [(Symbol, TableType)] where+ SchemaTables ('PartitionedSchema tables _ _ _ _ _ _) = tables+-- | Get the views from a @PartitionedSchema@+type family SchemaViews (schema :: PartitionedSchema) :: [(Symbol, RowType)] where+ SchemaViews ('PartitionedSchema _ views _ _ _ _ _) = views+-- | Get the typedefs from a @PartitionedSchema@+type family SchemaTypes (schema :: PartitionedSchema) :: [(Symbol, PGType)] where+ SchemaTypes ('PartitionedSchema _ _ types _ _ _ _) = types+-- | Get the indexes from a @PartitionedSchema@+type family SchemaIndexes (schema :: PartitionedSchema) :: [(Symbol, IndexType)] where+ SchemaIndexes ('PartitionedSchema _ _ _ indexes _ _ _) = indexes+-- | Get the functions from a @PartitionedSchema@+type family SchemaFunctions (schema :: PartitionedSchema) :: [(Symbol, FunctionType)] where+ SchemaFunctions ('PartitionedSchema _ _ _ _ functions _ _) = functions+-- | Get the procedured from a @PartitionedSchema@+type family SchemaProcedures (schema :: PartitionedSchema) :: [(Symbol, [NullType])] where+ SchemaProcedures ('PartitionedSchema _ _ _ _ _ procedures _) = procedures+-- | Get the unsafe schema types from a @PartitionedSchema@+type family SchemaUnsafes (schema :: PartitionedSchema) :: [(Symbol, Symbol)] where+ SchemaUnsafes ('PartitionedSchema _ _ _ _ _ _ unsafes) = unsafes++-- | @PrettyPrintPartitionedSchema@ makes a nice @ErrorMessage@ showing a @PartitionedSchema@,+-- only including the names of the things in it and not the values. Additionally, empty+-- fields are omitted+type family PrettyPrintPartitionedSchema (schema :: PartitionedSchema) :: ErrorMessage where+ PrettyPrintPartitionedSchema schema = IntersperseNewlines (FilterNonEmpty+ [ FieldIfNonEmpty "Tables" (SchemaTables schema)+ , FieldIfNonEmpty "Views" (SchemaViews schema)+ , FieldIfNonEmpty "Types" (SchemaTypes schema)+ , FieldIfNonEmpty "Indexes" (SchemaIndexes schema)+ , FieldIfNonEmpty "Functions" (SchemaFunctions schema)+ , FieldIfNonEmpty "Procedures" (SchemaProcedures schema)+ , FieldIfNonEmpty "Unsafe schema items" (SchemaUnsafes schema)+ ])++-- | Print field name (if corresponding values are non-empty).+type family FieldIfNonEmpty (fieldName :: Symbol) (value :: [(Symbol, k)]) :: ErrorMessage where+ FieldIfNonEmpty _ '[] = 'Text ""+ FieldIfNonEmpty n xs = 'Text " " ':<>: 'Text n ':<>: 'Text ":" ':$$: 'Text " " ':<>: 'ShowType (Sort (MapFst xs))++-- | Filter out empty error messages.+type family FilterNonEmpty (ls :: [ErrorMessage]) :: [ErrorMessage] where+ FilterNonEmpty ('Text "" ': rest) = FilterNonEmpty rest+ FilterNonEmpty (x ': rest) = x ': FilterNonEmpty rest+ FilterNonEmpty '[] = '[]++-- | Vertically concatenate error messages.+type family IntersperseNewlines (ls :: [ErrorMessage]) :: ErrorMessage where+ IntersperseNewlines (x ': y ': '[]) = x ':$$: y+ IntersperseNewlines (x ': xs) = x ':$$: IntersperseNewlines xs+ IntersperseNewlines '[] = 'Text ""++type instance PrettyPrintHaystack (haystack :: SchemaType) =+ 'PrettyPrintInfo ('Text "table, view, typedef, index, function, or procedure (SchemumType)") ('Text "schema (SchemaType)")+ ( PrettyPrintPartitionedSchema (PartitionSchema haystack)+ )++{- |+A database contains one or more named schemas, which in turn contain tables.+The same object name can be used in different schemas without conflict;+for example, both schema1 and myschema can contain tables named mytable.+Unlike databases, schemas are not rigidly separated:+a user can access objects in any of the schemas in the database they are connected to,+if they have privileges to do so.++There are several reasons why one might want to use schemas:++ * To allow many users to use one database without interfering with each other.+ * To organize database objects into logical groups to make them more manageable.+ * Third-party applications can be put into separate schemas+ so they do not collide with the names of other objects.+-}+type SchemasType = [(Symbol,SchemaType)]++type instance PrettyPrintHaystack (haystack :: SchemasType) =+ 'PrettyPrintInfo ('Text "schema (SchemaType)") ('Text "database (SchemasType)") ('Text " " ':<>: 'ShowType (Sort (MapFst haystack)))++-- | A type family to use for a single schema database.+type family Public (schema :: SchemaType) :: SchemasType+ where Public schema = '["public" ::: schema]++-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas+-- the overloaded label, `fromLabel` is used for column references,+-- `label`s are used for enum terms. A `label` is called with+-- type application like `label` @"beef".+class IsPGlabel (label :: Symbol) expr where label :: expr+instance label ~ label1+ => IsPGlabel label (PGlabel label1) where label = PGlabel+instance labels ~ '[label]+ => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil+instance IsPGlabel label (y -> K y label) where label = K+instance IsPGlabel label (y -> NP (K y) '[label]) where label y = K y :* Nil+instance {-# OVERLAPPING #-}+ IsPGlabel label0 (NS PGlabel (label0 ': labels)) where+ label = Z PGlabel+instance {-# OVERLAPPABLE #-} IsPGlabel label0 (NS PGlabel labels)+ => IsPGlabel label0 (NS PGlabel (label1 ': labels)) where+ label = S (label @label0)+-- | A `PGlabel` unit type with an `IsPGlabel` instance+data PGlabel (label :: Symbol) = PGlabel+instance KnownSymbol label => RenderSQL (PGlabel label) where+ renderSQL _ = "\'" <> renderSymbol @label <> "\'"+instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where+ renderSQL+ = commaSeparated+ . hcollapse+ . hcmap (Proxy @KnownSymbol) (K . renderSQL)++-- | Is a type a valid JSON key?+type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]++-- | Is a type a valid JSON type?+type PGJsonType = '[ 'PGjson, 'PGjsonb ]++-- | Utility class for `AllUnique` to provide nicer error messages.+class IsNotElem x isElem where+instance IsNotElem x 'False where+instance (TypeError ( 'Text "Cannot assign to "+ ':<>: 'ShowType alias+ ':<>: 'Text " more than once"))+ => IsNotElem '(alias, a) 'True where++-- | No elem of @xs@ appears more than once, in the context of assignment.+class AllUnique (xs :: [(Symbol, a)]) where+instance AllUnique '[] where+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where++-- | Updatable lists of columns+type Updatable table columns =+ ( All (HasIn (TableToColumns table)) columns+ , AllUnique columns+ , SListI (TableToColumns table) )++{- | Filters a schema down to labels of all enum typedefs.+-}+type family SchemaEnums schema where+ SchemaEnums '[] = '[]+ SchemaEnums (enum ::: 'Typedef ('PGenum labels) ': schema) =+ enum ::: labels ': SchemaEnums schema+ SchemaEnums (_ ': schema) = SchemaEnums schema++{- | Filters schemas down to labels of all enum typedefs.+-}+type family DbEnums db where+ DbEnums '[] = '[]+ DbEnums (sch ::: schema ': schemas) =+ sch ::: SchemaEnums schema ': DbEnums schemas++{- | Filters a schema down to rows of relations;+all composites, tables and views.+-}+type family SchemaRelations schema where+ SchemaRelations '[] = '[]+ SchemaRelations (ty ::: 'Typedef ('PGcomposite row) ': schema) =+ ty ::: row ': SchemaRelations schema+ SchemaRelations (tab ::: 'Table table ': schema) =+ tab ::: TableToRow table ': SchemaRelations schema+ SchemaRelations (vw ::: 'View row ': schema) =+ vw ::: row ': SchemaRelations schema+ SchemaRelations (_ ': schema) = SchemaRelations schema++{- | Filters schemas down to rows of relations;+all composites, tables and views.+-}+type family DbRelations db where+ DbRelations '[] = '[]+ DbRelations (sch ::: schema ': schemas) =+ sch ::: SchemaRelations schema ': DbRelations schemas++-- | Used in `FindQualified`+type family FindName xs x where+ FindName '[] xs = 'Nothing+ FindName ( '(name, x) ': _) x = 'Just name+ FindName (_ ': xs) x = FindName xs x++-- | Used in `FindQualified`+type family FindNamespace err nsp name xss x where+ FindNamespace err _ 'Nothing xss x = FindQualified err xss x+ FindNamespace _ nsp ('Just name) _ _ = '(nsp, name)++{- | Find fully qualified name with a type error if lookup fails.+This is used to find the qualified name of a user defined type.++>>> :kind! FindQualified "my error message:"+FindQualified "my error message:" :: [(k1, [(k2, k3)])]+ -> k3 -> (k1, k2)+= FindQualified "my error message:"++>>> :kind! FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Double+FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Double :: (Symbol,+ Symbol)+= '("foo", "bar")++>>> :kind! FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Bool+FindQualified "couldn't find type:" '[ "foo" ::: '["bar" ::: Double]] Bool :: (Symbol,+ Symbol)+= (TypeError ...)+-}+type family FindQualified err xss x where+ FindQualified err '[] x = TypeError+ ('Text err ':$$: 'ShowType x)+ FindQualified err ( '(nsp, xs) ': xss) x =+ FindNamespace err nsp (FindName xs x) xss x
+ test/Doc.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Test.DocTest++main :: IO ()+main = doctest [ "-isrc", "src" ]
− test/DocTest.hs
@@ -1,18 +0,0 @@-module Main (main) where--import Test.DocTest--main :: IO ()-main = doctest- [ "-isrc"- , "src/Squeal/PostgreSQL.hs"- , "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"- , "src/Squeal/PostgreSQL/Migration.hs"- , "src/Squeal/PostgreSQL/Transaction.hs"- , "src/Squeal/PostgreSQL/Pool.hs"- ]
+ test/Property.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE+ DataKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , DerivingVia+ , FlexibleContexts+ , FlexibleInstances+ , GADTs+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , ScopedTypeVariables+ , StandaloneDeriving+ , TypeApplications+ , TypeOperators+ , UndecidableInstances+#-}++module Main (main) where++import Control.Monad.Trans+import Data.ByteString (ByteString)+import Data.ByteString.Char8 (unpack)+import Data.Function (on)+import Data.Functor.Contravariant (contramap)+import Data.Int (Int16)+import Data.Scientific (fromFloatDigits)+import Data.Fixed (Fixed(MkFixed), Micro, Pico)+import Data.String (IsString(fromString))+import Data.Time+import Hedgehog hiding (Range)+import Main.Utf8+import Squeal.PostgreSQL hiding (check)+import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Main as Main+import qualified Hedgehog.Range as Range+import Data.List (sort)++main :: IO ()+main = withUtf8 $ do+ withConnection connectionString $ define createDB+ Main.defaultMain [checkSequential roundtrips]+ withConnection connectionString $ define dropDB++roundtrips :: Group+roundtrips = Group "roundtrips"+ [ roundtrip int2 genInt16+ , roundtrip int4 genInt32+ , roundtrip int8 genInt64+ , roundtrip bool Gen.bool+ , roundtrip numeric genScientific+ , roundtrip float4 genFloat+ , roundtrip float8 genDouble+ , roundtripOn normalizeAscii text genStringAscii+ , roundtripOn normalizeUtf8 text genStringUnicode+ -- , roundtripOn normalizeUtf8 text genStringAll+ , roundtripOn normalizeTimeOfDay time genTimeOfDay+ -- , roundtrip timetz genTimeWithZone+ , roundtripOn normalizeLocalTime timestamp genLocalTime+ , roundtrip timestamptz genUTCTime+ , roundtrip date genDay+ , roundtrip interval genDiffTime+ , roundtripOn normalizeIntRange int4range (genRange genInt32)+ , roundtripOn normalizeIntRange int8range (genRange genInt64)+ , roundtrip numrange (genRange genScientific)+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)+ , roundtrip tstzrange (genRange genUTCTime)+ , roundtripOn normalizeIntRange daterange (genRange genDay)+ , roundtrip (typedef #schwarma) genSchwarma+ , roundtrip (vararray (typedef #schwarma)) genSchwarmaArray+ , roundtrip (typerow #tab) genRow+ , roundtrip (vararray (typetable #tab)) genRowArray+ , ("table insert", roundtripTable)+ ]+ where+ genInt16 = Gen.int16 Range.exponentialBounded+ genInt32 = Gen.int32 Range.exponentialBounded+ genInt64 = Gen.int64 Range.exponentialBounded+ genScientific = fromFloatDigits <$> genFloat+ genPosFloat = Gen.float+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)+ genFloat = Gen.prune $ Gen.choice+ [ genPosFloat+ , negate <$> genPosFloat+ , Gen.element [0,1/0,-1/0]+ ]+ genPosDouble = Gen.double+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)+ genDouble = Gen.prune $ Gen.choice+ [ genPosDouble+ , negate <$> genPosDouble+ , Gen.element [0,1/0,-1/0]+ ]+ genStringAscii = Gen.string (Range.linear 0 100) Gen.ascii+ -- genStringLatin1 = Gen.string (Range.linear 0 100) Gen.latin1+ genStringUnicode = Gen.string (Range.linear 0 100) Gen.unicode+ -- genStringAll = Gen.string (Range.linear 0 100) Gen.unicodeAll+ genRange gen = do+ lb <- gen+ ub <- Gen.filter (lb <) gen+ Gen.element+ [ Empty, singleton lb, whole+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]+ genDay = do+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)+ m <- Gen.int (Range.constant 1 12)+ d <- Gen.int (Range.constant 1 28)+ return $ fromGregorian y m d+ genDiffTime = do+ secs <- secondsToDiffTime . toInteger <$>+ Gen.int (Range.constant 0 86401)+ picos <- picosecondsToDiffTime . (* 1000000) . toInteger <$>+ Gen.int (Range.constant 0 (1000000 - 1))+ return $ secs + picos+ genUTCTime = UTCTime <$> genDay <*> genDiffTime+ genTimeOfDay = do+ h <- Gen.int (Range.constant 0 23)+ m <- Gen.int (Range.constant 0 59)+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)+ return $ TimeOfDay h m s+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay+ -- genTimeZone = Gen.element $ map (read @TimeZone)+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]+ genSchwarma = Gen.enumBounded @_ @Schwarma+ genSchwarmaArray = VarArray <$> Gen.list (Range.constant 1 10) genSchwarma+ genRow = HaskRow+ <$> genInt16+ <*> Gen.enumBounded+ <*> Gen.bool+ genRowArray = VarArray <$> Gen.list (Range.constant 1 10) genRow++roundtrip+ :: forall x+ . ( ToPG DB x, FromPG x, Inline x+ , OidOf DB (PG x), PGTyped DB (PG x)+ , Show x, Eq x, NullPG x ~ 'NotNull (PG x) )+ => TypeExpression DB ('NotNull (PG x))+ -> Gen x+ -> (PropertyName, Property)+roundtrip = roundtripOn id++roundtripOn+ :: forall x+ . ( ToPG DB x, FromPG x, Inline x+ , OidOf DB (PG x), PGTyped DB (PG x)+ , Show x, Eq x, NullPG x ~ 'NotNull (PG x) )+ => (x -> x)+ -> TypeExpression DB ('NotNull (PG x))+ -> Gen x+ -> (PropertyName, Property)+roundtripOn norm ty gen = propertyWithName $ do+ x <- forAll gen+ Just (Only y) <- lift . withConnection connectionString $+ firstRow =<< runQueryParams+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)+ Just (Only z) <- lift . withConnection connectionString $+ firstRow =<< runQuery+ (values_ (inline @x @'NotNull x `as` #fromOnly))+ y === z+ norm x === y+ where+ propertyWithName prop =+ (fromString (unpack (renderSQL ty)), property prop)++maxPosFloat :: RealFloat a => a+maxPosFloat = x+ where+ n = floatDigits x+ b = floatRadix x+ (_, u) = floatRange x+ x = encodeFloat (b^n - 1) (u - n)++minPosFloat :: RealFloat a => a+minPosFloat = x+ where+ n = floatDigits x+ b = floatRadix x+ (l, _) = floatRange x+ x = encodeFloat (b^n - 1) (l - n - 1)++connectionString :: ByteString+connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"++normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int+normalizeIntRange = \case+ Empty -> Empty+ NonEmpty l u ->+ let+ l' = normalizeL l+ u' = normalizeU u+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'+ where+ normalizeL = \case+ Open l -> Closed (succ l)+ normalized -> normalized+ normalizeU = \case+ Closed u -> Open (succ u)+ normalized -> normalized+ emptyNormalized (Closed l) (Open u) = l >= u+ emptyNormalized _ _ = False++normalizeTimeOfDay :: TimeOfDay -> TimeOfDay+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m+ . fromRational @Pico+ . toRational @Micro+ . fromRational @Micro+ . toRational @Pico+ $ s++normalizeLocalTime :: LocalTime -> LocalTime+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)++-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)++normalizeAscii :: String -> String+normalizeAscii = (stripped =<<)+ where+ stripped = \case+ '\NUL' -> ""+ ch -> [ch]++normalizeUtf8 :: String -> String+normalizeUtf8 = (stripped =<<)+ where+ stripped = \case+ '\NUL' -> ""+ ch -> [ch]++data Schwarma = Chicken | Lamb | Beef+ deriving stock (Eq, Ord, Show, Bounded, Enum, GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving (IsPG, FromPG, ToPG db, Inline) via Enumerated Schwarma++data HaskRow = HaskRow {foo :: Int16, bar :: Schwarma, baz :: Bool}+ deriving stock (Eq, Ord, Show, GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+ deriving (IsPG, FromPG, Inline) via Composite HaskRow+deriving via Composite HaskRow+ instance db ~ DB => ToPG db HaskRow++type Schema = '[+ "schwarma" ::: 'Typedef (PG Schwarma),+ "tab" ::: 'Table ('[] :=> PGRow)]++type DB = Public Schema++type DB0 = Public '[]++createDB :: Definition DB0 DB+createDB =+ createTypeEnumFrom @Schwarma #schwarma >>>+ createTable #tab+ ( notNullable int2 `as` #foo :*+ notNullable (typedef #schwarma) `as` #bar :*+ notNullable bool `as` #baz+ ) Nil++dropDB :: Definition DB DB0+dropDB = dropTable #tab >>> dropType #schwarma++type PGRow = '[+ "foo" ::: 'NoDef :=> 'NotNull 'PGint2,+ "bar" ::: 'NoDef :=> 'NotNull (PG Schwarma),+ "baz" ::: 'NoDef :=> 'NotNull 'PGbool]++insertTabInline :: [HaskRow] -> Statement DB () ()+insertTabInline = \case+ [] -> error "needs at least 1 row"+ rw:rows -> manipulation $ insertInto_ #tab (inlineValues rw rows)++insertTabParams :: Statement DB HaskRow ()+insertTabParams = manipulation . insertInto_ #tab . Values_ $+ Set (param @1) `as` #foo :*+ Set (param @2) `as` #bar :*+ Set (param @3) `as` #baz++insertTabUnnest :: Statement DB [HaskRow] ()+insertTabUnnest = Manipulation enc dec sql+ where+ enc = contramap VarArray aParam+ dec = return ()+ sql = insertInto_ #tab unnested+ unnested = Select fields (from (unnest (param @1)))+ fields =+ Set (#unnest & field #tab #foo) `as` #foo :*+ Set (#unnest & field #tab #bar) `as` #bar :*+ Set (#unnest & field #tab #baz) `as` #baz++selectTab :: Statement DB () HaskRow+selectTab = query $ select Star (from (table #tab))++roundtripTable :: Property+roundtripTable = property $ do+ let+ genInt16 = Gen.int16 Range.exponentialBounded+ genRow = HaskRow+ <$> genInt16+ <*> Gen.enumBounded+ <*> Gen.bool+ genRows = Gen.list (Range.constant 1 100) genRow+ rows1 <- forAll genRows+ rows2 <- forAll genRows+ rows3 <- forAll genRows+ tabRows <- lift . withConnection connectionString $ ephemerally_ $ do+ execute_ (insertTabInline rows1)+ executePrepared_ insertTabParams rows2+ executeParams_ insertTabUnnest rows3+ getRows =<< execute selectTab+ ((===) `on` sort) tabRows (rows1 ++ rows2 ++ rows3)
+ test/Spec.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE+ DataKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , DerivingVia+ , DuplicateRecordFields+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , OverloadedLabels+ , OverloadedStrings+ , RankNTypes+ , StandaloneDeriving+ , TypeApplications+ , TypeFamilies+ , TypeSynonymInstances+ , DataKinds+ , PolyKinds+ , TypeOperators+ , UndecidableInstances+#-}++module Main (main) where++import Control.Concurrent.Async (replicateConcurrently)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Text (Text)+import Test.Hspec++import qualified Data.ByteString.Char8 as Char8 (unlines)+import qualified Generics.SOP as SOP+import qualified GHC.Generics as GHC++import Squeal.PostgreSQL++main :: IO ()+main = hspec spec++type UsersConstraints =+ '[ "pk_users" ::: 'PrimaryKey '["id"]+ , "unique_names" ::: 'Unique '["name"] ]++type UsersColumns =+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]++type Schema =+ '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)+ , "person" ::: 'Typedef (PG Person) ]++type DB = '[ "public" ::: Schema ]++data User = User+ { userName :: Text+ } deriving stock (Eq, Show, GHC.Generic)+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)++insertUser :: Manipulation_ DB User ()+insertUser = insertInto_ #users+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))++insertUsers :: Text -> [Text] -> Statement DB () ()+insertUsers name1 names = manipulation $ insertInto_ #users $ Values+ (Default `as` #id :* Set (inline name1) `as` #name)+ [Default `as` #id :* Set (inline namei) `as` #name | namei <- names]++deleteUser :: Text -> Statement DB () ()+deleteUser name1 = manipulation $ deleteFrom_ #users (#name .== inline name1)++setup :: Definition (Public '[]) DB+setup =+ createTable #users+ ( serial `as` #id :*+ notNullable text `as` #name )+ ( primaryKey #id `as` #pk_users :*+ unique #name `as` #unique_names ) >>>+ createTypeCompositeFrom @Person #person++teardown :: Definition DB (Public '[])+teardown = dropType #person >>> dropTable #users++silent :: Statement db () ()+silent = manipulation $ UnsafeManipulation "Set client_min_messages TO WARNING"++silence :: MonadPQ db pq => pq ()+silence = execute_ silent++setupDB :: IO ()+setupDB = withConnection connectionString $+ silence & pqThen (define setup)++dropDB :: IO ()+dropDB = withConnection connectionString $+ silence & pqThen (define teardown)++connectionString :: ByteString+connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"++data Person = Person { name :: Maybe String, age :: Maybe Int32 }+ deriving (Eq, Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)+ deriving (IsPG, FromPG, ToPG db, Inline) via (Composite Person)++spec :: Spec+spec = before_ setupDB . after_ dropDB $ do++ describe "Exceptions" $ do++ let+ testUser = User "TestUser"+ newUser :: User -> Transaction DB ()+ newUser usr = manipulateParams_ insertUser usr+ insertUserTwice :: Transaction DB ()+ insertUserTwice = newUser testUser >> newUser testUser+ err23505 = UniqueViolation $ Char8.unlines+ [ "ERROR: duplicate key value violates unique constraint \"unique_names\""+ , "DETAIL: Key (name)=(TestUser) already exists." ]++ it "should be thrown for constraint violation" $+ withConnection connectionString insertUserTwice+ `shouldThrow` (== err23505)++ it "should be rethrown for constraint violation in a transaction" $+ withConnection connectionString (transactionally_ insertUserTwice)+ `shouldThrow` (== err23505)++ describe "Pools" $++ it "should manage concurrent transactions" $ do+ pool <- createConnectionPool+ "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10+ let+ qry :: Query_ (Public '[]) () (Only Char)+ qry = values_ (inline 'a' `as` #fromOnly)+ session = usingConnectionPool pool $ transactionally_ $+ firstRow =<< runQuery qry+ chrs <- replicateConcurrently 10 session+ chrs `shouldSatisfy` all (== Just (Only 'a'))++ describe "Ranges" $++ it "should correctly decode ranges" $ do++ rangesOut <- withConnection connectionString $ do+ let+ qry :: Query_ (Public '[]) () (Only (Range Int32))+ qry = values+ ( range int4range (atLeast 3) `as` #fromOnly )+ [ range int4range (3 <=..< 5) `as` #fromOnly+ , range int4range Empty `as` #fromOnly+ , range int4range whole `as` #fromOnly ]+ getRows =<< runQuery qry+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`+ [ atLeast 3, 3 <=..< 5, Empty, whole ]++ describe "Parameters" $ do++ it "should run queries that don't reference all their parameters" $ do++ out <- withConnection connectionString $ do+ let+ qry :: Query_ (Public '[]) (Char,Int32) (Only Int32)+ qry = values_ (param @2 `as` #fromOnly)+ firstRow =<< runQueryParams qry ('a', 3 :: Int32)+ (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3++ describe "Composite types" $ do++ it "should be embeddible" $ do++ let++ roundtrip :: Query_ DB (Only Person) (Only Person)+ roundtrip = values_ (param @1 `as` #fromOnly)++ roundtrip_inline :: Person -> Query_ DB () (Only Person)+ roundtrip_inline person = values_ (inline person `as` #fromOnly)++ roundtrip_array :: Query_ DB+ (Only (VarArray [Person])) (Only (VarArray [Person]))+ roundtrip_array = values_ (param @1 `as` #fromOnly)++ oneway :: Query_ DB () (Only Person)+ oneway = values_ (row ("Adam" `as` #name :* 6000 `as` #age) `as` #fromOnly)++ oneway_array :: Query_ DB () (Only (VarArray [Person]))+ oneway_array = values_ $ array+ [ row ("Adam" `as` #name :* 6000 `as` #age)+ , row ("Lucy" `as` #name :* 2420000 `as` #age)+ ] `as` #fromOnly++ unsafeQ :: Query_ DB () (Only (VarArray [Composite Person]))+ unsafeQ = UnsafeQuery "select array[row(\'Adam\', 6000)]"++ nothingQ :: Query_ DB () (Only Person)+ nothingQ = values_ (row (null_ `as` #name :* null_ `as` #age) `as` #fromOnly)++ adam = Person (Just "Adam") (Just 6000)+ lucy = Person (Just "Lucy") (Just 2420000)+ people = VarArray [adam, lucy]++ out <- withConnection connectionString $+ firstRow =<< runQueryParams roundtrip (Only adam)+ out_inline <- withConnection connectionString $+ firstRow =<< runQuery (roundtrip_inline adam)+ out_array <- withConnection connectionString $+ firstRow =<< runQueryParams roundtrip_array (Only people)+ out2 <- withConnection connectionString $+ firstRow =<< runQuery oneway+ out2_array <- withConnection connectionString $+ firstRow =<< runQuery oneway_array+ unsafe_array <- withConnection connectionString $+ firstRow =<< runQuery unsafeQ+ nothings <- withConnection connectionString $+ firstRow =<< runQuery nothingQ++ out `shouldBe` Just (Only adam)+ out_inline `shouldBe` Just (Only adam)+ out_array `shouldBe` Just (Only people)+ out2 `shouldBe` Just (Only adam)+ out2_array `shouldBe` Just (Only people)+ unsafe_array `shouldBe` Just (Only (VarArray [Composite adam]))+ nothings `shouldBe` Just (Only (Person Nothing Nothing))++ describe "cmdStatus and cmdTuples" $ do++ let+ statusAndTuples stmnt = withConnection connectionString $ do+ result <- execute stmnt+ status <- cmdStatus result+ tuples <- cmdTuples result+ return (status, tuples)++ it "should tell you about the command and the number of rows effected" $ do++ (status1, tuples1) <- statusAndTuples (insertUsers "Jonah" ["Isaiah"])+ status1 `shouldBe` "INSERT 0 2"+ tuples1 `shouldBe` Just 2++ (status2, tuples2) <- statusAndTuples (deleteUser "Noah")+ status2 `shouldBe` "DELETE 0"+ tuples2 `shouldBe` Just 0++ (status3, tuples3) <- statusAndTuples (deleteUser "Jonah")+ status3 `shouldBe` "DELETE 1"+ tuples3 `shouldBe` Just 1++ (status4, tuples4) <- statusAndTuples silent+ status4 `shouldBe` "SET"+ tuples4 `shouldBe` Nothing
− test/Specs/ExceptionHandling.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-module ExceptionHandling- ( specs- , User (..)- ) where--import Control.Concurrent.Async (replicateConcurrently)-import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO (..))-import Data.Int (Int16)-import Data.Text (Text)-import Data.Vector (Vector)-import Test.Hspec--import qualified Data.ByteString.Char8 as Char8-import qualified Generics.SOP as SOP-import qualified GHC.Generics as GHC--import Squeal.PostgreSQL--type Schema =- '[ "users" ::: 'Table (- '[ "pk_users" ::: 'PrimaryKey '["id"]- , "unique_names" ::: 'Unique '["name"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "name" ::: 'NoDef :=> 'NotNull 'PGtext- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))- ])- , "emails" ::: 'Table (- '[ "pk_emails" ::: 'PrimaryKey '["id"]- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]- ] :=>- '[ "id" ::: 'Def :=> 'NotNull 'PGint4- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4- , "email" ::: 'NoDef :=> 'Null 'PGtext- ])- ]--type Schemas = Public Schema--data User =- User { userName :: Text- , userEmail :: Maybe Text- , userVec :: VarArray (Vector (Maybe Int16)) }- deriving (Show, GHC.Generic)-instance SOP.Generic User-instance SOP.HasDatatypeInfo User--insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]- '[ "fromOnly" ::: 'NotNull 'PGint4 ]-insertUser = insertInto #users- (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))- OnConflictDoRaise (Returning (#id `as` #fromOnly))--setup :: Definition (Public '[]) Schemas-setup =- createTable #users- ( serial `as` #id :*- (text & notNullable) `as` #name :*- (vararray int2 & notNullable) `as` #vec )- ( primaryKey #id `as` #pk_users- :* unique #name `as` #unique_names )- >>>- createTable #emails- ( serial `as` #id :*- (int & notNullable) `as` #user_id :*- (text & nullable) `as` #email )- ( primaryKey #id `as` #pk_emails :*- foreignKey #user_id #users #id- OnDeleteCascade OnUpdateCascade `as` #fk_user_id )--teardown :: Definition Schemas (Public '[])-teardown = dropTable #emails >>> dropTable #users--migration :: Migration Definition (Public '[]) Schemas-migration = Migration { name = "test"- , up = setup- , down = teardown }--setupDB :: IO ()-setupDB = withConnection connectionString $- manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")- & pqThen (migrateUp (single migration))--dropDB :: IO ()-dropDB = withConnection connectionString $- manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")- & pqThen (migrateDown (single migration))--connectionString :: Char8.ByteString-connectionString = "host=localhost port=5432 dbname=exampledb"--testUser :: User-testUser = User "TestUser" Nothing (VarArray [])--newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()-newUser u = void $ manipulateParams insertUser (userName u, userVec u)--insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()-insertUserTwice = newUser testUser >> newUser testUser--specs :: SpecWith ()-specs = before_ setupDB $ after_ dropDB $- describe "Exceptions" $ do-- let- dupKeyErr = PQException $ PQState FatalError (Just "23505")- (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")-- it "should be thrown for unique constraint violation in a manipulation" $- withConnection connectionString insertUserTwice- `shouldThrow` (== dupKeyErr)-- it "should be rethrown for unique constraint violation in a manipulation by a transaction" $- withConnection connectionString (transactionally_ insertUserTwice)- `shouldThrow` (== dupKeyErr)-- it "should handle concurrent transactions using pooled connections" $ do- pool <- createConnectionPool- "host=localhost port=5432 dbname=exampledb" 1 0.5 10- let- query :: Query_ (Public '[]) () (Only Char)- query = values_ (literal 'a' `as` #fromOnly)- session = usingConnectionPool pool . transactionally_ $ do- result <- runQuery query- Just (Only chr) <- firstRow result- return chr- chrs <- replicateConcurrently 10 session- chrs `shouldSatisfy` (all (== 'a'))
− test/Specs/Specs.hs
@@ -1,7 +0,0 @@-module Main where--import Test.Hspec-import qualified ExceptionHandling--main :: IO ()-main = hspec ExceptionHandling.specs