squeal-postgresql 0.5.2.0 → 0.6.0.0

raw patch · 85 files changed

+11898/−6994 lines, 85 filesdep +QuickCheckdep +binarydep +free-categoriesdep ~basedep ~generics-sopdep ~mtlnew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, binary, free-categories, gauge, generic-random, hedgehog, monad-loops, profunctors, quickcheck-instances, with-utf8

Dependency ranges changed: base, generics-sop, mtl, text

API changes (from Hackage documentation)

Files

• bench/Gauge.hs +116/−0
• bench/Gauge/DBHelpers.hs +73/−0
• bench/Gauge/DBSetup.hs +136/−0
• bench/Gauge/Queries.hs +149/−0
• bench/Gauge/Schema.hs +93/−0
• exe/Example.hs +16/−10
• squeal-postgresql.cabal +102/−23
• src/Squeal/PostgreSQL.hs +72/−39
• src/Squeal/PostgreSQL/Alias.hs +0/−249
• src/Squeal/PostgreSQL/Binary.hs +0/−757
• src/Squeal/PostgreSQL/Definition.hs +85/−1108
• src/Squeal/PostgreSQL/Definition/Constraint.hs +341/−0
• src/Squeal/PostgreSQL/Definition/Function.hs +249/−0
• src/Squeal/PostgreSQL/Definition/Index.hs +186/−0
• src/Squeal/PostgreSQL/Definition/Schema.hs +113/−0
• src/Squeal/PostgreSQL/Definition/Table.hs +497/−0
• src/Squeal/PostgreSQL/Definition/Type.hs +247/−0
• src/Squeal/PostgreSQL/Definition/View.hs +135/−0
• src/Squeal/PostgreSQL/Expression.hs +367/−116
• src/Squeal/PostgreSQL/Expression/Aggregate.hs +258/−174
• src/Squeal/PostgreSQL/Expression/Array.hs +139/−0
• src/Squeal/PostgreSQL/Expression/Collection.hs +0/−169
• src/Squeal/PostgreSQL/Expression/Comparison.hs +26/−22
• src/Squeal/PostgreSQL/Expression/Composite.hs +93/−0
• src/Squeal/PostgreSQL/Expression/Default.hs +60/−0
• src/Squeal/PostgreSQL/Expression/Inline.hs +331/−0
• src/Squeal/PostgreSQL/Expression/Json.hs +71/−78
• 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 +37/−18
• src/Squeal/PostgreSQL/Expression/Parameter.hs +18/−17
• 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 +23/−21
• src/Squeal/PostgreSQL/Expression/Text.hs +13/−12
• src/Squeal/PostgreSQL/Expression/TextSearch.hs +27/−26
• src/Squeal/PostgreSQL/Expression/Time.hs +25/−26
• src/Squeal/PostgreSQL/Expression/Type.hs +287/−89
• src/Squeal/PostgreSQL/Expression/Window.hs +138/−94
• src/Squeal/PostgreSQL/List.hs +0/−141
• src/Squeal/PostgreSQL/Manipulation.hs +74/−351
• src/Squeal/PostgreSQL/Manipulation/Delete.hs +101/−0
• src/Squeal/PostgreSQL/Manipulation/Insert.hs +259/−0
• src/Squeal/PostgreSQL/Manipulation/Update.hs +97/−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 +72/−707
• src/Squeal/PostgreSQL/Query/From.hs +110/−0
• src/Squeal/PostgreSQL/Query/From/Join.hs +296/−0
• src/Squeal/PostgreSQL/Query/From/Set.hs +204/−0
• src/Squeal/PostgreSQL/Query/Select.hs +252/−0
• src/Squeal/PostgreSQL/Query/Table.hs +289/−0
• src/Squeal/PostgreSQL/Query/Values.hs +88/−0
• src/Squeal/PostgreSQL/Query/With.hs +123/−0
• src/Squeal/PostgreSQL/Render.hs +15/−5
• src/Squeal/PostgreSQL/Schema.hs +0/−449
• src/Squeal/PostgreSQL/Session.hs +295/−0
• src/Squeal/PostgreSQL/Session/Connection.hs +78/−0
• src/Squeal/PostgreSQL/Session/Decode.hs +445/−0
• src/Squeal/PostgreSQL/Session/Encode.hs +508/−0
• src/Squeal/PostgreSQL/Session/Exception.hs +96/−0
• src/Squeal/PostgreSQL/Session/Indexed.hs +126/−0
• src/Squeal/PostgreSQL/Session/Migration.hs +458/−0
• src/Squeal/PostgreSQL/Session/Monad.hs +267/−0
• src/Squeal/PostgreSQL/Session/Oid.hs +221/−0
• src/Squeal/PostgreSQL/Session/Pool.hs +124/−0
• src/Squeal/PostgreSQL/Session/Result.hs +182/−0
• src/Squeal/PostgreSQL/Session/Statement.hs +127/−0
• src/Squeal/PostgreSQL/Session/Transaction.hs +253/−0
• src/Squeal/PostgreSQL/Transaction.hs +0/−252
• src/Squeal/PostgreSQL/Type.hs +161/−0
• src/Squeal/PostgreSQL/Type/Alias.hs +260/−0
• src/Squeal/PostgreSQL/Type/List.hs +118/−0
• src/Squeal/PostgreSQL/Type/PG.hs +334/−0
• src/Squeal/PostgreSQL/Type/Schema.hs +612/−0
• test/Doc.hs +6/−0
• test/DocTest.hs +0/−18
• test/Property.hs +205/−0
• test/Spec.hs +212/−0
• test/Specs/ExceptionHandling.hs +0/−140
• test/Specs/Specs.hs +0/−7

@@ -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

@@ -0,0 +1,73 @@+{-# 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           Data.ByteString                ( ByteString )+import qualified Data.ByteString.Char8         as C+import qualified Data.Text                     as T+import           Control.Monad                  ( void )+import           Control.Monad.Except           ( MonadIO+                                                , throwError+                                                )+import           Control.Monad.IO.Class         ( liftIO )+import           Control.Monad.Loops            ( iterateWhile )+import           GHC.Generics                   ( Generic+                                                , Generic1+                                                )+import           Test.QuickCheck+import           Squeal.PostgreSQL+import qualified Data.ByteString.Char8         as C+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 (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

@@ -0,0 +1,136 @@+{-# 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           Test.QuickCheck+import           Squeal.PostgreSQL+-- Project imports+import           Gauge.Schema                   ( Schemas+                                                , DeviceOS+                                                , IPLocation+                                                )+import           Gauge.Queries                  ( InsertUser )+++-- First create enums as they're needed in the Schema+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 OnDeleteCascade OnUpdateCascade+          `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"++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;"

@@ -0,0 +1,149 @@+{-# 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(..)+                                                , PrintableString(..)+                                                , listOf+                                                , arbitraryPrintableChar+                                                )+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)

@@ -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"] "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]

@@ -13,7 +13,6 @@  import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32)-import Data.Monoid ((<>)) import Data.Text (Text) import Data.Vector (Vector) @@ -38,6 +37,7 @@         , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4         , "email" ::: 'NoDef :=> 'Null 'PGtext         ])+   , "positive" ::: 'Typedef 'PGfloat4    ]  type Schemas = Public Schema@@ -52,14 +52,16 @@   >>>   createTable #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 )+    >>>+    createDomain #positive real (#value .> 0 .&& (#value & isNotNull))  teardown :: Definition Schemas (Public '[])-teardown = dropTable #emails >>> dropTable #users+teardown = dropType #positive >>> dropTable #emails >>> dropTable #users  insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32) insertUser = insertInto #users@@ -77,23 +79,27 @@     & innerJoin (table (#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)+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])   ]  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+  ids <- traverse (fmap fromOnly . getRow 0) (idResults :: [Result (Only Int32)])   traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))   liftIO $ Char8.putStrLn "querying"   usersResult <- runQuery getUsers

@@ -1,5 +1,5 @@ name: squeal-postgresql-version: 0.5.2.0+version: 0.6.0.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal@@ -22,20 +22,27 @@   hs-source-dirs: src   exposed-modules:     Squeal.PostgreSQL-    Squeal.PostgreSQL.Alias-    Squeal.PostgreSQL.Binary     Squeal.PostgreSQL.Definition+    Squeal.PostgreSQL.Definition.Constraint+    Squeal.PostgreSQL.Definition.Function+    Squeal.PostgreSQL.Definition.Index+    Squeal.PostgreSQL.Definition.Table+    Squeal.PostgreSQL.Definition.Type+    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,31 +50,55 @@     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.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.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+    , binary >= 0.8.6.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+    , free-categories >= 0.2.0.0+    , generics-sop >= 0.3.2.0     , mmorph >= 1.1.1     , mtl >= 2.2.2     , network-ip >= 0.3.0.2     , postgresql-binary >= 0.12.1     , postgresql-libpq >= 0.9.4.1+    , profunctors >= 5.3     , records-sop >= 0.1.0.0     , resource-pool >= 0.2.3.2     , scientific >= 0.3.5.3@@ -79,35 +110,83 @@     , uuid-types >= 1.0.3     , vector >= 0.12.0.1 -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+    , squeal-postgresql -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: Specs.hs-  other-modules: ExceptionHandling+  main-is: Property.hs   build-depends:       base >= 4.10.0.0-    , async >= 2.2.2     , bytestring >= 0.10.8.2+    , hedgehog >= 1.0+    , mtl >= 2.2.2+    , scientific >= 0.3.5.3+    , squeal-postgresql+    , time >= 1.8.0.2+    , with-utf8 >= 1.0++test-suite spec+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  ghc-options: -Wall+  main-is: Spec.hs+  build-depends:+      async >= 2.2.2+    , base >= 4.10.0.0+    , bytestring >= 0.10.8.2     , generics-sop >= 0.3.1.0     , hspec >= 2.4.8+    , mtl >= 2.2.2     , squeal-postgresql     , text >= 1.2.2.2-    , transformers >= 0.5.2.0     , vector >= 0.12.0.1 -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.10.0.0+    , bytestring >= 0.10.8.2+    , deepseq >= 1.4.3.0+    , gauge >= 0.2.5+    , generic-random >= 1.2.0.0+    , generics-sop >= 0.3.1.0+    , monad-loops >= 0.4.3+    , mtl >= 2.2.2+    , QuickCheck >= 2.13.2+    , quickcheck-instances >= 0.3.22+    , scientific >= 0.3.5.3+    , squeal-postgresql+    , text >= 1.2.2.2+    , with-utf8 >= 1.0++executable example   default-language: Haskell2010   hs-source-dirs: exe   ghc-options: -Wall

@@ -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@@ -44,7 +44,7 @@ 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 :*@@ -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))@@ -136,15 +138,14 @@ >>> 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" -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,12 +177,12 @@  >>> :{ 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" $     define setup@@ -190,22 +191,33 @@ :} [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}] -}-module Squeal.PostgreSQL (module 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.Constraint as X+import Squeal.PostgreSQL.Definition.Function as X+import Squeal.PostgreSQL.Definition.Index 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 +225,34 @@ 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.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

@@ -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

@@ -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))

@@ -1,1110 +1,87 @@ {-| 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+  , TypeInType+  , 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

@@ -0,0 +1,341 @@+{-|+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+  , TypeInType+  , TypeOperators+  , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Constraint+  ( -- * Table Constraints+    TableConstraintExpression (..)+  , check+  , unique+  , primaryKey+    -- ** Foreign Keys+  , foreignKey+  , ForeignKeyed+  , OnDeleteClause (..)+  , OnUpdateClause (..)+  ) 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"] "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 db 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 db+      ('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 db+  sch+  schema+  child parent+  table reftable+  columns refcolumns+  constraints cols+  reftys tys =+    ( Has sch db 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"

@@ -0,0 +1,249 @@+{-|+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+  , TypeInType+  , 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

@@ -0,0 +1,186 @@+{-|+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+  , TypeInType+  , 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 <> ";"

@@ -0,0 +1,113 @@+{-|+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+  , TypeInType+  , 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;"

@@ -0,0 +1,497 @@+{-|+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+  , TypeInType+  , TypeOperators+  , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Table+  ( -- * Create+    createTable+  , createTableIfNotExists+    -- * Drop+  , dropTable+  , dropTableIfExists+    -- * Alter+  , alterTable+  , alterTableIfExists+  , alterTableRename+  , alterTableIfExistsRename+  , 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.+--+-- >>> printSQL $ alterTableRename #foo #bar+-- ALTER TABLE "foo" RENAME TO "bar";+alterTableRename+  :: (KnownSymbol tab0, KnownSymbol tab1)+  => Alias tab0 -- ^ table to rename+  -> Alias tab1 -- ^ what to rename it+  -> Definition schema (Rename tab0 tab1 schema)+alterTableRename tab0 tab1 = UnsafeDefinition $+  "ALTER TABLE" <+> renderSQL tab0+  <+> "RENAME TO" <+> renderSQL tab1 <> ";"++-- | Rename a table if it exists.+alterTableIfExistsRename+  :: (KnownSymbol tab0, KnownSymbol tab1)+  => Alias tab0 -- ^ table to rename+  -> Alias tab1 -- ^ what to rename it+  -> Definition schema (RenameIfExists tab0 tab1 schema)+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $+  "ALTER TABLE IF EXISTS" <+> renderSQL tab0+  <+> "RENAME TO" <+> renderSQL tab1 <> ";"++-- | 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

@@ -0,0 +1,247 @@+{-|+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+  , TypeInType+  , TypeOperators+  , UndecidableSuperClasses+#-}++module Squeal.PostgreSQL.Definition.Type+  ( -- * Create+    createTypeEnum+  , createTypeEnumFrom+  , createTypeComposite+  , createTypeCompositeFrom+  , createTypeRange+  , createDomain+    -- * Drop+  , dropType+  , dropTypeIfExists+  ) 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 <> ";"