{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : Database.Relational.Schema.PostgreSQL
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module implements queries to get
-- table schema and table constraint informations
-- from system catalog of PostgreSQL.
module Database.Relational.Schema.PostgreSQL (
  module Database.Relational.Schema.PostgreSQL.Config,

  Column,

  normalizeColumn, notNull, getType,

  columnQuerySQL,
  primaryKeyLengthQuerySQL, primaryKeyQuerySQL
  ) where

import Prelude hiding (or)

import Language.Haskell.TH (TypeQ)

import Data.Int (Int16, Int32, Int64)
import Data.Char (toLower)
import Data.List (foldl1')
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Time
  (DiffTime, NominalDiffTime,
   LocalTime, ZonedTime, Day, TimeOfDay)

import Database.Relational
  (Query, relationalQuery, Relation, query, query', relation', relation, union,
   wheres, (.=.), (.>.), not', in', values, (!), fst', snd',
   placeholder, asc, value, unsafeProjectSql, (><))

import Database.Relational.Schema.PostgreSQL.Config
import Database.Relational.Schema.PostgreSQL.PgNamespace (pgNamespace)
import qualified Database.Relational.Schema.PostgreSQL.PgNamespace as Namespace
import Database.Relational.Schema.PostgreSQL.PgClass (pgClass)
import qualified Database.Relational.Schema.PostgreSQL.PgClass as Class
import Database.Relational.Schema.PostgreSQL.PgConstraint (PgConstraint, pgConstraint)
import qualified Database.Relational.Schema.PostgreSQL.PgConstraint as Constraint

import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute, pgAttribute)
import qualified Database.Relational.Schema.PostgreSQL.PgAttribute as Attr
import Database.Relational.Schema.PostgreSQL.PgType (PgType(..), pgType)
import qualified Database.Relational.Schema.PostgreSQL.PgType as Type

import Control.Applicative ((<|>))


-- | Mapping between type in PostgreSQL and Haskell type.
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault :: Map String TypeQ
mapFromSqlDefault =
  [(String, TypeQ)] -> Map String TypeQ
forall k a. Ord k => [(k, a)] -> Map k a
fromList [("bool",         [t| Bool |]),
            ("char",         [t| Char |]),
            ("name",         [t| String |]),
            ("int8",         [t| Int64 |]),
            ("int2",         [t| Int16 |]),
            ("int4",         [t| Int32 |]),
            -- ("regproc",      [t| Int32 |]),
            ("text",         [t| String |]),
            ("oid",          [t| Int32 |]),
            -- ("pg_node_tree", [t| String |]),
            ("float4",       [t| Float |]),
            ("float8",       [t| Double |]),
            ("abstime",      [t| LocalTime |]),
            ("reltime",      [t| NominalDiffTime |]),
            ("tinterval",    [t| DiffTime |]),
            -- ("money",        [t| Decimal |]),
            ("bpchar",       [t| String |]),
            ("varchar",      [t| String |]),
            ("uuid",         [t| String |]),
            ("date",         [t| Day |]),
            ("time",         [t| TimeOfDay |]),
            ("timestamp",    [t| LocalTime |]),
            ("timestamptz",  [t| ZonedTime |]),
            ("interval",     [t| DiffTime |]),
            ("timetz",       [t| ZonedTime |])

            -- ("bit", [t|  |]),
            -- ("varbit", [t|  |]),
            -- ("numeric", [t| Decimal |])
           ]

-- | Normalize column name string to query PostgreSQL system catalog.
normalizeColumn :: String -> String
normalizeColumn :: String -> String
normalizeColumn =  (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

-- | Type to represent Column information.
type Column = (PgAttribute, PgType)

-- | Not-null attribute information of column.
notNull :: Column -> Bool
notNull :: Column -> Bool
notNull =  PgAttribute -> Bool
Attr.attnotnull (PgAttribute -> Bool) -> (Column -> PgAttribute) -> Column -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Column -> PgAttribute
forall a b. (a, b) -> a
fst

-- | Get column normalized name and column Haskell type.
getType :: Map String TypeQ      -- ^ Type mapping specified by user
        -> Column                -- ^ Column info in system catalog
        -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type
getType :: Map String TypeQ -> Column -> Maybe (String, TypeQ)
getType mapFromSql :: Map String TypeQ
mapFromSql column :: Column
column@(pgAttr :: PgAttribute
pgAttr, pgTyp :: PgType
pgTyp) = do
  TypeQ
typ <- (String -> Map String TypeQ -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSql
          Maybe TypeQ -> Maybe TypeQ -> Maybe TypeQ
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          String -> Map String TypeQ -> Maybe TypeQ
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String TypeQ
mapFromSqlDefault)
  (String, TypeQ) -> Maybe (String, TypeQ)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
normalizeColumn (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ PgAttribute -> String
Attr.attname PgAttribute
pgAttr,
          TypeQ -> TypeQ
mayNull TypeQ
typ)
  where key :: String
key = PgType -> String
Type.typname PgType
pgTyp
        mayNull :: TypeQ -> TypeQ
mayNull typ :: TypeQ
typ = if Column -> Bool
notNull Column
column
                      then TypeQ
typ
                      else [t| Maybe $typ |]

-- | 'Relation' to query PostgreSQL relation oid from schema name and table name.
relOidRelation :: Relation (String, String) Int32
relOidRelation :: Relation (String, String) Int32
relOidRelation = SimpleQuery (String, String) Int32
-> Relation (String, String) Int32
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) Int32
 -> Relation (String, String) Int32)
-> SimpleQuery (String, String) Int32
-> Relation (String, String) Int32
forall a b. (a -> b) -> a -> b
$ do
  Record Flat PgNamespace
nsp <- Relation () PgNamespace
-> Orderings Flat QueryCore (Record Flat PgNamespace)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgNamespace
pgNamespace
  Record Flat PgClass
cls <- Relation () PgClass
-> Orderings Flat QueryCore (Record Flat PgClass)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgClass
pgClass

  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgClass
cls Record Flat PgClass -> Pi PgClass Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgClass Int32
Class.relnamespace' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgNamespace
nsp Record Flat PgNamespace
-> Pi PgNamespace Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgNamespace Int32
Namespace.oid'
  (nspP :: PlaceHolders String
nspP, ()) <- (Record Flat String -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders String, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\ph :: Record Flat String
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgNamespace
nsp Record Flat PgNamespace
-> Pi PgNamespace String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgNamespace String
Namespace.nspname'  Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)
  (relP :: PlaceHolders String
relP, ()) <- (Record Flat String -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders String, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\ph :: Record Flat String
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgClass
cls Record Flat PgClass -> Pi PgClass String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgClass String
Class.relname'      Record Flat String -> Record Flat String -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat String
ph)

  (PlaceHolders (String, String), Record Flat Int32)
-> SimpleQuery (String, String) Int32
forall (m :: * -> *) a. Monad m => a -> m a
return   (PlaceHolders String
nspP PlaceHolders String
-> PlaceHolders String -> PlaceHolders (String, String)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< PlaceHolders String
relP, Record Flat PgClass
cls Record Flat PgClass -> Pi PgClass Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgClass Int32
Class.oid')

-- | 'Relation' to query column attribute from schema name and table name.
attributeRelation :: Relation (String, String) PgAttribute
attributeRelation :: Relation (String, String) PgAttribute
attributeRelation =  SimpleQuery (String, String) PgAttribute
-> Relation (String, String) PgAttribute
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) PgAttribute
 -> Relation (String, String) PgAttribute)
-> SimpleQuery (String, String) PgAttribute
-> Relation (String, String) PgAttribute
forall a b. (a -> b) -> a -> b
$ do
  (ph :: PlaceHolders (String, String)
ph, reloid :: Record Flat Int32
reloid) <- Relation (String, String) Int32
-> SimpleQuery (String, String) Int32
forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) Int32
relOidRelation
  Record Flat PgAttribute
att          <- Relation () PgAttribute
-> Orderings Flat QueryCore (Record Flat PgAttribute)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query  Relation () PgAttribute
pgAttribute

  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int32
Attr.attrelid' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
reloid
  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute Int16 -> Record Flat Int16
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int16
Attr.attnum'   Record Flat Int16 -> Record Flat Int16 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.>. Int16 -> Record Flat Int16
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value 0

  (PlaceHolders (String, String), Record Flat PgAttribute)
-> SimpleQuery (String, String) PgAttribute
forall (m :: * -> *) a. Monad m => a -> m a
return   (PlaceHolders (String, String)
ph, Record Flat PgAttribute
att)

-- | 'Relation' to query 'Column' from schema name and table name.
columnRelation :: Relation (String, String) Column
columnRelation :: Relation (String, String) Column
columnRelation = SimpleQuery (String, String) Column
-> Relation (String, String) Column
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) Column
 -> Relation (String, String) Column)
-> SimpleQuery (String, String) Column
-> Relation (String, String) Column
forall a b. (a -> b) -> a -> b
$ do
  (ph :: PlaceHolders (String, String)
ph, att :: Record Flat PgAttribute
att) <- Relation (String, String) PgAttribute
-> SimpleQuery (String, String) PgAttribute
forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) PgAttribute
attributeRelation
  Record Flat PgType
typ       <- Relation () PgType -> Orderings Flat QueryCore (Record Flat PgType)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query  Relation () PgType
pgType

  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int32
Attr.atttypid'    Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgType
typ Record Flat PgType -> Pi PgType Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgType Int32
Type.oid'
  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgType
typ Record Flat PgType -> Pi PgType Char -> Record Flat Char
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgType Char
Type.typtype'     Record Flat Char -> Record Flat Char -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Char -> Record Flat Char
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value 'b'  -- 'b': base type only

  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Predicate Flat -> Predicate Flat
forall c.
OperatorContext c =>
Record c (Maybe Bool) -> Record c (Maybe Bool)
not' (Predicate Flat -> Predicate Flat)
-> Predicate Flat -> Predicate Flat
forall a b. (a -> b) -> a -> b
$ Record Flat PgType
typ Record Flat PgType -> Pi PgType Char -> Record Flat Char
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgType Char
Type.typcategory' Record Flat Char -> RecordList (Record Flat) Char -> Predicate Flat
forall c t.
OperatorContext c =>
Record c t -> RecordList (Record c) t -> Record c (Maybe Bool)
`in'`
                  String -> RecordList (Record Flat) Char
forall t c.
(LiteralSQL t, OperatorContext c) =>
[t] -> RecordList (Record c) t
values
                  [ 'C' -- Composite types
                  , 'P' -- Pseudo-types
                  , 'X' -- unknown type
                  ]

  Record Flat Int16 -> Orderings Flat QueryCore ()
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc (Record Flat Int16 -> Orderings Flat QueryCore ())
-> Record Flat Int16 -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute Int16 -> Record Flat Int16
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int16
Attr.attnum'

  (PlaceHolders (String, String), Record Flat Column)
-> SimpleQuery (String, String) Column
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, Record Flat PgAttribute
att Record Flat PgAttribute -> Record Flat PgType -> Record Flat Column
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< Record Flat PgType
typ)

-- | Phantom typed 'Query' to get 'Column' from schema name and table name.
columnQuerySQL :: Query (String, String) Column
columnQuerySQL :: Query (String, String) Column
columnQuerySQL =  Relation (String, String) Column -> Query (String, String) Column
forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) Column
columnRelation

-- | 'Relation' to query primary key length from schema name and table name.
primaryKeyLengthRelation :: Relation (String, String) Int32
primaryKeyLengthRelation :: Relation (String, String) Int32
primaryKeyLengthRelation =  SimpleQuery (String, String) Int32
-> Relation (String, String) Int32
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) Int32
 -> Relation (String, String) Int32)
-> SimpleQuery (String, String) Int32
-> Relation (String, String) Int32
forall a b. (a -> b) -> a -> b
$ do
  (ph :: PlaceHolders (String, String)
ph, reloid :: Record Flat Int32
reloid) <- Relation (String, String) Int32
-> SimpleQuery (String, String) Int32
forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) Int32
relOidRelation
  Record Flat PgConstraint
con       <- Relation () PgConstraint
-> Orderings Flat QueryCore (Record Flat PgConstraint)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query  Relation () PgConstraint
pgConstraint

  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con Record Flat PgConstraint
-> Pi PgConstraint Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Int32
Constraint.conrelid' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat Int32
reloid
  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con Record Flat PgConstraint
-> Pi PgConstraint Char -> Record Flat Char
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Char
Constraint.contype'  Record Flat Char -> Record Flat Char -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Char -> Record Flat Char
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value 'p'  -- 'p': primary key constraint type

  (PlaceHolders (String, String), Record Flat Int32)
-> SimpleQuery (String, String) Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, String -> Record Flat Int32
forall c t. SqlContext c => String -> Record c t
unsafeProjectSql "array_length (conkey, 1)")

-- | Phantom typed 'Query' to get primary key length from schema name and table name.
primaryKeyLengthQuerySQL :: Query (String, String) Int32
primaryKeyLengthQuerySQL :: Query (String, String) Int32
primaryKeyLengthQuerySQL =  Relation (String, String) Int32 -> Query (String, String) Int32
forall p r. Relation p r -> Query p r
relationalQuery Relation (String, String) Int32
primaryKeyLengthRelation

-- | One column which is nth column of composite primary key.
constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation i :: Int32
i = QuerySimple (Record Flat (PgConstraint, (Int16, Int32)))
-> Relation () (PgConstraint, (Int16, Int32))
forall r. QuerySimple (Record Flat r) -> Relation () r
relation (QuerySimple (Record Flat (PgConstraint, (Int16, Int32)))
 -> Relation () (PgConstraint, (Int16, Int32)))
-> QuerySimple (Record Flat (PgConstraint, (Int16, Int32)))
-> Relation () (PgConstraint, (Int16, Int32))
forall a b. (a -> b) -> a -> b
$ do
  Record Flat PgConstraint
con <- Relation () PgConstraint
-> Orderings Flat QueryCore (Record Flat PgConstraint)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () PgConstraint
pgConstraint

  Record Flat (PgConstraint, (Int16, Int32))
-> QuerySimple (Record Flat (PgConstraint, (Int16, Int32)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Record Flat (PgConstraint, (Int16, Int32))
 -> QuerySimple (Record Flat (PgConstraint, (Int16, Int32))))
-> Record Flat (PgConstraint, (Int16, Int32))
-> QuerySimple (Record Flat (PgConstraint, (Int16, Int32)))
forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con Record Flat PgConstraint
-> Record Flat (Int16, Int32)
-> Record Flat (PgConstraint, (Int16, Int32))
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< (String -> Record Flat Int16
forall c t. SqlContext c => String -> Record c t
unsafeProjectSql ("conkey[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]") Record Flat Int16
-> Record Flat Int32 -> Record Flat (Int16, Int32)
forall (p :: * -> *) a b.
ProductIsoApplicative p =>
p a -> p b -> p (a, b)
>< Int32 -> Record Flat Int32
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value Int32
i)

-- | Make composite primary key relation from primary key length.
constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation n :: Int32
n =
  (Relation () (PgConstraint, (Int16, Int32))
 -> Relation () (PgConstraint, (Int16, Int32))
 -> Relation () (PgConstraint, (Int16, Int32)))
-> [Relation () (PgConstraint, (Int16, Int32))]
-> Relation () (PgConstraint, (Int16, Int32))
forall a. (a -> a -> a) -> [a] -> a
foldl1' Relation () (PgConstraint, (Int16, Int32))
-> Relation () (PgConstraint, (Int16, Int32))
-> Relation () (PgConstraint, (Int16, Int32))
forall a. Relation () a -> Relation () a -> Relation () a
union [Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColRelation Int32
i | Int32
i <- [1..Int32
n] ]

-- | 'Relation' to query primary key name from schema name and table name.
primaryKeyRelation :: Int32 -> Relation (String, String) String
primaryKeyRelation :: Int32 -> Relation (String, String) String
primaryKeyRelation n :: Int32
n = SimpleQuery (String, String) String
-> Relation (String, String) String
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery (String, String) String
 -> Relation (String, String) String)
-> SimpleQuery (String, String) String
-> Relation (String, String) String
forall a b. (a -> b) -> a -> b
$ do
  (ph :: PlaceHolders (String, String)
ph, att :: Record Flat PgAttribute
att) <- Relation (String, String) PgAttribute
-> SimpleQuery (String, String) PgAttribute
forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query' Relation (String, String) PgAttribute
attributeRelation
  Record Flat (PgConstraint, (Int16, Int32))
conEx     <- Relation () (PgConstraint, (Int16, Int32))
-> QuerySimple (Record Flat (PgConstraint, (Int16, Int32)))
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query  (Int32 -> Relation () (PgConstraint, (Int16, Int32))
constraintColExpandRelation Int32
n)

  let con :: Record Flat PgConstraint
con = Record Flat (PgConstraint, (Int16, Int32))
conEx Record Flat (PgConstraint, (Int16, Int32))
-> Pi (PgConstraint, (Int16, Int32)) PgConstraint
-> Record Flat PgConstraint
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi (PgConstraint, (Int16, Int32)) PgConstraint
forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) a
fst'
      col' :: Record Flat (Int16, Int32)
col' = Record Flat (PgConstraint, (Int16, Int32))
conEx Record Flat (PgConstraint, (Int16, Int32))
-> Pi (PgConstraint, (Int16, Int32)) (Int16, Int32)
-> Record Flat (Int16, Int32)
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi (PgConstraint, (Int16, Int32)) (Int16, Int32)
forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) b
snd'
      keyIx :: Record Flat Int16
keyIx = Record Flat (Int16, Int32)
col' Record Flat (Int16, Int32)
-> Pi (Int16, Int32) Int16 -> Record Flat Int16
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi (Int16, Int32) Int16
forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) a
fst'
      keyN :: Record Flat Int32
keyN  = Record Flat (Int16, Int32)
col' Record Flat (Int16, Int32)
-> Pi (Int16, Int32) Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi (Int16, Int32) Int32
forall a b. (PersistableWidth a, PersistableWidth b) => Pi (a, b) b
snd'

  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con Record Flat PgConstraint
-> Pi PgConstraint Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Int32
Constraint.conrelid' Record Flat Int32 -> Record Flat Int32 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute Int32 -> Record Flat Int32
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int32
Attr.attrelid'
  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat Int16
keyIx Record Flat Int16 -> Record Flat Int16 -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute Int16 -> Record Flat Int16
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute Int16
Attr.attnum'
  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat PgConstraint
con Record Flat PgConstraint
-> Pi PgConstraint Char -> Record Flat Char
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgConstraint Char
Constraint.contype'  Record Flat Char -> Record Flat Char -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Char -> Record Flat Char
forall t c. (LiteralSQL t, OperatorContext c) => t -> Record c t
value 'p'  -- 'p': primary key constraint type

  Record Flat Int32 -> Orderings Flat QueryCore ()
forall (m :: * -> *) c t. Monad m => Record c t -> Orderings c m ()
asc  (Record Flat Int32 -> Orderings Flat QueryCore ())
-> Record Flat Int32 -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat Int32
keyN

  (PlaceHolders (String, String), Record Flat String)
-> SimpleQuery (String, String) String
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders (String, String)
ph, Record Flat PgAttribute
att Record Flat PgAttribute
-> Pi PgAttribute String -> Record Flat String
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Pi PgAttribute String
Attr.attname')

-- | Phantom typed 'Query' to get primary key name from schema name and table name.
primaryKeyQuerySQL :: Int32 -> Query (String, String) String
primaryKeyQuerySQL :: Int32 -> Query (String, String) String
primaryKeyQuerySQL =  Relation (String, String) String -> Query (String, String) String
forall p r. Relation p r -> Query p r
relationalQuery (Relation (String, String) String -> Query (String, String) String)
-> (Int32 -> Relation (String, String) String)
-> Int32
-> Query (String, String) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Relation (String, String) String
primaryKeyRelation