{-|
Module: Squeal.PostgreSQL.Session.Encode
Description: encoding of statement parameters
Copyright: (c) Eitan Chatav, 2019
Maintainer: eitan@morphism.tech
Stability: experimental

encoding of statement parameters
-}

{-# LANGUAGE
    AllowAmbiguousTypes
  , ConstraintKinds
  , DataKinds
  , DefaultSignatures
  , FlexibleContexts
  , FlexibleInstances
  , LambdaCase
  , MultiParamTypeClasses
  , PolyKinds
  , RankNTypes
  , ScopedTypeVariables
  , TypeApplications
  , TypeFamilies
  , TypeOperators
  , UndecidableInstances
  , UndecidableSuperClasses
#-}

module Squeal.PostgreSQL.Session.Encode
  ( -- * Encode Parameters
    EncodeParams (..)
  , GenericParams (..)
  , nilParams
  , (.*)
  , (*.)
  , aParam
  , appendParams
  , enumParam
  , rowParam
  , genericRowParams
  , (.#)
  , (#.)
    -- * Encoding Classes
  , ToPG (..)
  , ToParam (..)
  , ToField (..)
  , ToArray (..)
  ) where

import ByteString.StrictBuilder
import Control.Monad
import Control.Monad.Reader
import Data.Bits
import Data.ByteString as Strict (ByteString)
import Data.ByteString.Lazy as Lazy (ByteString)
import Data.Coerce (coerce)
import Data.Functor.Const (Const(Const))
import Data.Functor.Constant (Constant(Constant))
import Data.Functor.Contravariant
import Data.Int (Int16, Int32, Int64)
import Data.Kind
import Data.Scientific (Scientific)
import Data.Text as Strict (Text)
import Data.Text.Lazy as Lazy (Text)
import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
import Data.UUID.Types (UUID)
import Data.Vector (Vector)
import Data.Word (Word32)
import Foreign.C.Types (CUInt(CUInt))
import GHC.TypeLits
import Network.IP.Addr (NetAddr, IP)
import PostgreSQL.Binary.Encoding hiding (Composite, field)

import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as Lazy.ByteString
import qualified Data.Text as Strict.Text
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Generics.SOP as SOP
import qualified Generics.SOP.Record as SOP

import Squeal.PostgreSQL.Expression.Range
import Squeal.PostgreSQL.Session.Oid
import Squeal.PostgreSQL.Type
import Squeal.PostgreSQL.Type.Alias
import Squeal.PostgreSQL.Type.List
import Squeal.PostgreSQL.Type.PG
import Squeal.PostgreSQL.Type.Schema

-- $setup
-- >>> import Squeal.PostgreSQL (connectdb, finish)

-- | A `ToPG` constraint gives an encoding of a Haskell `Type` into
-- into the binary format of a PostgreSQL `PGType`.
class IsPG x => ToPG (db :: SchemasType) (x :: Type) where
  -- | >>> :set -XTypeApplications -XDataKinds
  -- >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
  -- >>> runReaderT (toPG @'[] False) conn
  -- "\NUL"
  --
  -- >>> runReaderT (toPG @'[] (0 :: Int16)) conn
  -- "\NUL\NUL"
  --
  -- >>> runReaderT (toPG @'[] (0 :: Int32)) conn
  -- "\NUL\NUL\NUL\NUL"
  --
  -- >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving
  -- >>> newtype UserId = UserId { getUserId :: Int64 } deriving newtype (IsPG, ToPG db)
  -- >>> runReaderT (toPG @'[] (UserId 0)) conn
  -- "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL"
  --
  -- >>> finish conn
  toPG :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding
instance ToPG db Bool where toPG :: Bool -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Encoding
bool
instance ToPG db Int16 where toPG :: Int16 -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Encoding
int2_int16
instance ToPG db Int32 where toPG :: Int32 -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Encoding
int4_int32
instance ToPG db Int64 where toPG :: Int64 -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Encoding
int8_int64
instance ToPG db Oid where toPG :: Oid -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Encoding
int4_word32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Oid -> Word32
getOid
instance ToPG db Float where toPG :: Float -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Encoding
float4
instance ToPG db Double where toPG :: Double -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Encoding
float8
instance ToPG db Scientific where toPG :: Scientific -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Encoding
numeric
instance ToPG db Money where toPG :: Money -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Encoding
int8_int64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Money -> Int64
cents
instance ToPG db UUID where toPG :: UUID -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Encoding
uuid
instance ToPG db (NetAddr IP) where toPG :: NetAddr IP -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetAddr IP -> Encoding
inet
instance ToPG db Char where toPG :: Char -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Encoding
char_utf8
instance ToPG db Strict.Text where toPG :: Text -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_strict
instance ToPG db Lazy.Text where toPG :: Text -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_lazy
instance ToPG db String where
  toPG :: String -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_strict forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Strict.Text.pack
instance ToPG db Strict.ByteString where toPG :: ByteString -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoding
bytea_strict
instance ToPG db Lazy.ByteString where toPG :: ByteString -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoding
bytea_lazy
instance ToPG db (VarChar n) where toPG :: VarChar n -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_strict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). VarChar n -> Text
getVarChar
instance ToPG db (FixChar n) where toPG :: FixChar n -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_strict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). FixChar n -> Text
getFixChar
instance ToPG db x => ToPG db (Const x tag) where toPG :: Const x tag -> ReaderT (K Connection db) IO Encoding
toPG = forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db @x forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce
instance ToPG db x => ToPG db (SOP.K x tag) where toPG :: K x tag -> ReaderT (K Connection db) IO Encoding
toPG = forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db @x forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce
instance ToPG db x => ToPG db (Constant x tag) where toPG :: Constant x tag -> ReaderT (K Connection db) IO Encoding
toPG = forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db @x forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce
instance ToPG db Day where toPG :: Day -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> Encoding
date
instance ToPG db TimeOfDay where toPG :: TimeOfDay -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeOfDay -> Encoding
time_int
instance ToPG db (TimeOfDay, TimeZone) where toPG :: (TimeOfDay, TimeZone) -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeOfDay, TimeZone) -> Encoding
timetz_int
instance ToPG db LocalTime where toPG :: LocalTime -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> Encoding
timestamp_int
instance ToPG db UTCTime where toPG :: UTCTime -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Encoding
timestamptz_int
instance ToPG db DiffTime where toPG :: DiffTime -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Encoding
interval_int
instance ToPG db Aeson.Value where toPG :: Value -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Encoding
json_ast
instance Aeson.ToJSON x => ToPG db (Json x) where
  toPG :: Json x -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoding
json_bytes
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.ByteString.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall hask. Json hask -> hask
getJson
instance Aeson.ToJSON x => ToPG db (Jsonb x) where
  toPG :: Jsonb x -> ReaderT (K Connection db) IO Encoding
toPG = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Encoding
jsonb_bytes
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.ByteString.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall hask. Jsonb hask -> hask
getJsonb
instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty)
  => ToPG db (VarArray [x]) where
    toPG :: VarArray [x] -> ReaderT (K Connection db) IO Encoding
toPG (VarArray [x]
arr) = do
      Oid
oid <- forall (db :: SchemasType) (ty :: NullType).
OidOfNull db ty =>
ReaderT (K Connection db) IO Oid
oidOfNull @db @ty
      let
        dims :: [Int32]
dims = [forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [x]
arr)]
        nulls :: Bool
nulls = forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
Bool
arrayNulls @db @'[] @ty @x
      Encoding
payload <- forall (m :: * -> *) a c.
Functor m =>
(forall b. (b -> a -> m b) -> b -> c -> m b)
-> (a -> m Encoding) -> c -> m Encoding
dimArray forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
x -> ReaderT (K Connection db) IO Encoding
arrayPayload @db @'[] @ty @x) [x]
arr
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int32 -> Bool -> Oid -> [Int32] -> Encoding -> Encoding
encodeArray Int32
1 Bool
nulls Oid
oid [Int32]
dims Encoding
payload
instance (NullPG x ~ ty, ToArray db '[] ty x, OidOfNull db ty)
  => ToPG db (VarArray (Vector x)) where
    toPG :: VarArray (Vector x) -> ReaderT (K Connection db) IO Encoding
toPG (VarArray Vector x
arr) = do
      Oid
oid <- forall (db :: SchemasType) (ty :: NullType).
OidOfNull db ty =>
ReaderT (K Connection db) IO Oid
oidOfNull @db @ty
      let
        dims :: [Int32]
dims = [forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector x
arr)]
        nulls :: Bool
nulls = forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
Bool
arrayNulls @db @'[] @ty @x
      Encoding
payload <- forall (m :: * -> *) a c.
Functor m =>
(forall b. (b -> a -> m b) -> b -> c -> m b)
-> (a -> m Encoding) -> c -> m Encoding
dimArray forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
x -> ReaderT (K Connection db) IO Encoding
arrayPayload @db @'[] @ty @x) Vector x
arr
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int32 -> Bool -> Oid -> [Int32] -> Encoding -> Encoding
encodeArray Int32
1 Bool
nulls Oid
oid [Int32]
dims Encoding
payload
instance (ToArray db dims ty x, OidOfNull db ty)
  => ToPG db (FixArray x) where
    toPG :: FixArray x -> ReaderT (K Connection db) IO Encoding
toPG (FixArray x
arr) = do
      Oid
oid <- forall (db :: SchemasType) (ty :: NullType).
OidOfNull db ty =>
ReaderT (K Connection db) IO Oid
oidOfNull @db @ty
      Encoding
payload <- forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
x -> ReaderT (K Connection db) IO Encoding
arrayPayload @db @dims @ty x
arr
      let
        dims :: [Int32]
dims = forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
[Int32]
arrayDims @db @dims @ty @x
        nulls :: Bool
nulls = forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
Bool
arrayNulls @db @dims @ty @x
        ndims :: Int32
ndims = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
dims)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int32 -> Bool -> Oid -> [Int32] -> Encoding -> Encoding
encodeArray Int32
ndims Bool
nulls Oid
oid [Int32]
dims Encoding
payload
instance
  ( SOP.IsEnumType x
  , SOP.HasDatatypeInfo x
  , LabelsPG x ~ labels
  ) => ToPG db (Enumerated x) where
    toPG :: Enumerated x -> ReaderT (K Connection db) IO Encoding
toPG =
      let
        gshowConstructor
          :: NP SOP.ConstructorInfo xss
          -> SOP.SOP SOP.I xss
          -> String
        gshowConstructor :: forall (xss :: [[*]]).
NP ConstructorInfo xss -> SOP I xss -> String
gshowConstructor NP ConstructorInfo xss
Nil SOP I xss
_ = String
""
        gshowConstructor (ConstructorInfo x
constructor :* NP ConstructorInfo xs
_) (SOP.SOP (SOP.Z NP I x
_)) =
          forall (xs :: [*]). ConstructorInfo xs -> String
SOP.constructorName ConstructorInfo x
constructor
        gshowConstructor (ConstructorInfo x
_ :* NP ConstructorInfo xs
constructors) (SOP.SOP (SOP.S NS (NP I) xs
xs)) =
          forall (xss :: [[*]]).
NP ConstructorInfo xss -> SOP I xss -> String
gshowConstructor NP ConstructorInfo xs
constructors (forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP NS (NP I) xs
xs)
      in
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_strict
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Strict.Text.pack
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xss :: [[*]]).
NP ConstructorInfo xss -> SOP I xss -> String
gshowConstructor
          (forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
SOP.constructorInfo (forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
SOP.datatypeInfo (forall {k} (t :: k). Proxy t
SOP.Proxy @x)))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Generic a => a -> Rep a
SOP.from
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall enum. Enumerated enum -> enum
getEnumerated
instance
  ( SOP.SListI fields
  , SOP.IsRecord x xs
  , SOP.AllZip (ToField db) fields xs
  , SOP.All (OidOfField db) fields
  , RowPG x ~ fields
  ) => ToPG db (Composite x) where
    toPG :: Composite x -> ReaderT (K Connection db) IO Encoding
toPG = forall x (row :: [(ConstructorName, NullType)])
       (db :: SchemasType).
(PG x ~ 'PGcomposite row, All (OidOfField db) row) =>
EncodeParams db row x -> x -> ReaderT (K Connection db) IO Encoding
rowParam (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall record. Composite record -> record
getComposite forall (db :: SchemasType) (row :: [(ConstructorName, NullType)]) x
       (xs :: RecordCode).
(IsRecord x xs, AllZip (ToField db) row xs) =>
EncodeParams db row x
genericRowParams)
instance ToPG db x => ToPG db (Range x) where
  toPG :: Range x -> ReaderT (K Connection db) IO Encoding
toPG Range x
r = do
    Encoding
payload <- case Range x
r of
      Range x
Empty -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
      NonEmpty Bound x
lower Bound x
upper -> forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bound x -> ReaderT (K Connection db) IO Encoding
putBound Bound x
lower forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bound x -> ReaderT (K Connection db) IO Encoding
putBound Bound x
upper
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8 -> Encoding
word8 (Range x -> Word8 -> Word8
setFlags Range x
r Word8
0) forall a. Semigroup a => a -> a -> a
<> Encoding
payload
    where
      putBound :: Bound x -> ReaderT (K Connection db) IO Encoding
putBound = \case
        Bound x
Infinite -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
        Closed x
value -> Encoding -> Encoding
sized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db x
value
        Open x
value -> Encoding -> Encoding
sized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db x
value
      setFlags :: Range x -> Word8 -> Word8
setFlags = \case
        Range x
Empty -> (forall a. Bits a => a -> Int -> a
`setBit` Int
0)
        NonEmpty Bound x
lower Bound x
upper ->
          forall {x}. Bound x -> Word8 -> Word8
setLowerFlags Bound x
lower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {x}. Bound x -> Word8 -> Word8
setUpperFlags Bound x
upper
      setLowerFlags :: Bound x -> Word8 -> Word8
setLowerFlags = \case
        Bound x
Infinite -> (forall a. Bits a => a -> Int -> a
`setBit` Int
3)
        Closed x
_ -> (forall a. Bits a => a -> Int -> a
`setBit` Int
1)
        Open x
_ -> forall a. a -> a
id
      setUpperFlags :: Bound x -> Word8 -> Word8
setUpperFlags = \case
        Bound x
Infinite -> (forall a. Bits a => a -> Int -> a
`setBit` Int
4)
        Closed x
_ -> (forall a. Bits a => a -> Int -> a
`setBit` Int
2)
        Open x
_ -> forall a. a -> a
id

-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
-- into the binary format of a PostgreSQL `NullType`.
-- You should not define instances for `ToParam`,
-- just use the provided instances.
class ToParam (db :: SchemasType) (ty :: NullType) (x :: Type) where
  toParam :: x -> ReaderT (SOP.K LibPQ.Connection db) IO (Maybe Encoding)
instance (ToPG db x, pg ~ PG x) => ToParam db ('NotNull pg) x where
  toParam :: x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db
instance (ToPG db x, pg ~ PG x) => ToParam db ('Null pg) (Maybe x) where
  toParam :: Maybe x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db)

-- | A `ToField` constraint lifts the `ToPG` parser
-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,
-- encoding `Null`s to `Maybe`s. You should not define instances for
-- `ToField`, just use the provided instances.
class ToField
  (db :: SchemasType)
  (field :: (Symbol, NullType))
  (x :: (Symbol, Type)) where
  toField :: SOP.P x
    -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) field)
instance (fld0 ~ fld1, ToParam db ty x)
  => ToField db (fld0 ::: ty) (fld1 ::: x) where
    toField :: P (fld1 ::: x)
-> ReaderT (K Connection db) IO (K (Maybe Encoding) (fld0 ::: ty))
toField (SOP.P Snd (fld1 ::: x)
x) = forall k a (b :: k). a -> K a b
SOP.K forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (db :: SchemasType) (ty :: NullType) x.
ToParam db ty x =>
x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam @db @ty Snd (fld1 ::: x)
x

-- | A `ToArray` constraint gives an encoding of a Haskell `Type`
-- into the binary format of a PostgreSQL fixed-length array.
-- You should not define instances for
-- `ToArray`, just use the provided instances.
class ToArray
  (db :: SchemasType)
  (dims :: [Nat])
  (ty :: NullType)
  (x :: Type) where
  arrayPayload :: x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding
  arrayDims :: [Int32]
  arrayNulls :: Bool
instance (ToPG db x, pg ~ PG x)
  => ToArray db '[] ('NotNull pg) x where
  arrayPayload :: x -> ReaderT (K Connection db) IO Encoding
arrayPayload = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Encoding -> Encoding
sized forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db @x
  arrayDims :: [Int32]
arrayDims = []
  arrayNulls :: Bool
arrayNulls = Bool
False
instance (ToPG db x, pg ~ PG x)
  => ToArray db '[] ('Null pg) (Maybe x) where
  arrayPayload :: Maybe x -> ReaderT (K Connection db) IO Encoding
arrayPayload = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Encoding
null4) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Encoding -> Encoding
sized forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) x.
ToPG db x =>
x -> ReaderT (K Connection db) IO Encoding
toPG @db @x)
  arrayDims :: [Int32]
arrayDims = []
  arrayNulls :: Bool
arrayNulls = Bool
True
instance
  ( SOP.IsProductType tuple xs
  , Length xs ~ dim
  , SOP.All ((~) x) xs
  , ToArray db dims ty x
  , KnownNat dim )
  => ToArray db (dim ': dims) ty tuple where
    arrayPayload :: tuple -> ReaderT (K Connection db) IO Encoding
arrayPayload
      = forall (m :: * -> *) a c.
Functor m =>
(forall b. (b -> a -> m b) -> b -> c -> m b)
-> (a -> m Encoding) -> c -> m Encoding
dimArray forall x (xs :: [*]) (m :: * -> *) z.
(All ((~) x) xs, Monad m) =>
(z -> x -> m z) -> z -> NP I xs -> m z
foldlNP (forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
x -> ReaderT (K Connection db) IO Encoding
arrayPayload @db @dims @ty @x)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
SOP.unZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
SOP.unSOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Generic a => a -> Rep a
SOP.from
    arrayDims :: [Int32]
arrayDims
      = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
SOP.Proxy @dim))
      forall a. a -> [a] -> [a]
: forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
[Int32]
arrayDims @db @dims @ty @x
    arrayNulls :: Bool
arrayNulls = forall (db :: SchemasType) (dims :: [Nat]) (ty :: NullType) x.
ToArray db dims ty x =>
Bool
arrayNulls @db @dims @ty @x
foldlNP
  :: (SOP.All ((~) x) xs, Monad m)
  => (z -> x -> m z) -> z -> NP SOP.I xs -> m z
foldlNP :: forall x (xs :: [*]) (m :: * -> *) z.
(All ((~) x) xs, Monad m) =>
(z -> x -> m z) -> z -> NP I xs -> m z
foldlNP z -> x -> m z
f z
z = \case
  NP I xs
Nil -> forall (f :: * -> *) a. Applicative f => a -> f a
pure z
z
  SOP.I x
x :* NP I xs
xs -> do
    z
z' <- z -> x -> m z
f z
z x
x
    forall x (xs :: [*]) (m :: * -> *) z.
(All ((~) x) xs, Monad m) =>
(z -> x -> m z) -> z -> NP I xs -> m z
foldlNP z -> x -> m z
f z
z' NP I xs
xs

{- |
`EncodeParams` describes an encoding of a Haskell `Type`
into a list of parameter `NullType`s or into a `RowType`.

>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
>>> :{
let
  encode :: EncodeParams '[]
    '[ 'NotNull 'PGint2, 'NotNull ('PGchar 1), 'NotNull 'PGtext]
    (Int16, (Char, String))
  encode = fst .* fst.snd *. snd.snd
in runReaderT (runEncodeParams encode (1,('a',"foo"))) conn
:}
K (Just "\NUL\SOH") :* K (Just "a") :* K (Just "foo") :* Nil

>>> :{
let
  encode :: EncodeParams '[]
    '["fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)]
    (Int16, Char)
  encode = fst `as` #fst #. snd `as` #snd
in runReaderT (runEncodeParams encode (1,'a')) conn
:}
K (Just "\NUL\SOH") :* K (Just "a") :* Nil

>>> finish conn
-}
newtype EncodeParams
  (db :: SchemasType)
  (tys :: [k])
  (x :: Type) = EncodeParams
  { forall k (db :: SchemasType) (tys :: [k]) x.
EncodeParams db tys x
-> x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
runEncodeParams :: x
    -> ReaderT (SOP.K LibPQ.Connection db) IO (NP (SOP.K (Maybe Encoding)) tys) }
instance Contravariant (EncodeParams db tys) where
  contramap :: forall a' a.
(a' -> a) -> EncodeParams db tys a -> EncodeParams db tys a'
contramap a' -> a
f (EncodeParams a -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
g) = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams (a -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

-- | A `GenericParams` constraint to ensure that a Haskell type
-- is a product type,
-- has a `TuplePG`,
-- and all its terms have known Oids,
-- and can be encoded to corresponding Postgres types.
class
  ( SOP.IsProductType x xs
  , params ~ TuplePG x
  , SOP.All (OidOfNull db) params
  , SOP.AllZip (ToParam db) params xs
  ) => GenericParams db params x xs where
  {- | Parameter encoding for `SOP.Generic` tuples and records.

  >>> import qualified GHC.Generics as GHC
  >>> import qualified Generics.SOP as SOP
  >>> data Two = Two Int16 String deriving (GHC.Generic, SOP.Generic)
  >>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
  >>> :{
  let
    encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] Two
    encode = genericParams
  in runReaderT (runEncodeParams encode (Two 2 "two")) conn
  :}
  K (Just "\NUL\STX") :* K (Just "two") :* Nil

  >>> :{
  let
    encode :: EncodeParams '[] '[ 'NotNull 'PGint2, 'NotNull 'PGtext] (Int16, String)
    encode = genericParams
  in runReaderT (runEncodeParams encode (2, "two")) conn
  :}
  K (Just "\NUL\STX") :* K (Just "two") :* Nil

  >>> finish conn
  -}
  genericParams :: EncodeParams db params x
instance
  ( params ~ TuplePG x
  , SOP.All (OidOfNull db) params
  , SOP.IsProductType x xs
  , SOP.AllZip (ToParam db) params xs
  ) => GenericParams db params x xs where
  genericParams :: EncodeParams db params x
genericParams = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams
    forall a b. (a -> b) -> a -> b
$ forall {k} {k} (c :: k -> k -> Constraint) (ys :: [k]) (xs :: [k])
       (m :: * -> *) (f :: k -> *) (g :: k -> *).
(AllZip c ys xs, Applicative m) =>
Proxy c
-> (forall (y :: k) (x :: k). c y x => f x -> m (g y))
-> NP f xs
-> m (NP g ys)
hctransverse (forall {k} (t :: k). Proxy t
SOP.Proxy @(ToParam db)) forall (ty :: NullType) y.
ToParam db ty y =>
I y -> ReaderT (K Connection db) IO (K (Maybe Encoding) ty)
encodeNullParam
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
SOP.unZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
SOP.unSOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Generic a => a -> Rep a
SOP.from
    where
      encodeNullParam
        :: forall ty y. ToParam db ty y
        => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty)
      encodeNullParam :: forall (ty :: NullType) y.
ToParam db ty y =>
I y -> ReaderT (K Connection db) IO (K (Maybe Encoding) ty)
encodeNullParam = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a (b :: k). a -> K a b
SOP.K forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) (ty :: NullType) x.
ToParam db ty x =>
x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam @db @ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. I a -> a
SOP.unI

-- | Encode 0 parameters.
nilParams :: EncodeParams db '[] x
nilParams :: forall {k} (db :: SchemasType) x. EncodeParams db '[] x
nilParams = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams forall a b. (a -> b) -> a -> b
$ \ x
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (a :: k -> *). NP a '[]
Nil

{- | Cons a parameter encoding.

>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
>>> :{
let
  encode :: EncodeParams '[]
    '[ 'Null 'PGint4, 'NotNull 'PGtext]
    (Maybe Int32, String)
  encode = fst .* snd .* nilParams
in runReaderT (runEncodeParams encode (Nothing, "foo")) conn
:}
K Nothing :* K (Just "foo") :* Nil

>>> finish conn
-}
(.*)
  :: forall db x0 ty x tys. (ToParam db ty x0, ty ~ NullPG x0)
  => (x -> x0) -- ^ head
  -> EncodeParams db tys x -- ^ tail
  -> EncodeParams db (ty ': tys) x
x -> x0
f .* :: forall (db :: SchemasType) x0 (ty :: NullType) x
       (tys :: [NullType]).
(ToParam db ty x0, ty ~ NullPG x0) =>
(x -> x0) -> EncodeParams db tys x -> EncodeParams db (ty : tys) x
.* EncodeParams x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
params = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams forall a b. (a -> b) -> a -> b
$ \x
x ->
  forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
(:*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k a (b :: k). a -> K a b
SOP.K forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (db :: SchemasType) (ty :: NullType) x.
ToParam db ty x =>
x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam @db @ty (x -> x0
f x
x)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
params x
x
infixr 5 .*

{- | End a parameter encoding.

>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
>>> :{
let
  encode :: EncodeParams '[]
    '[ 'Null 'PGint4, 'NotNull 'PGtext, 'NotNull ('PGchar 1)]
    (Maybe Int32, String, Char)
  encode = (\(x,_,_) -> x) .* (\(_,y,_) -> y) *. (\(_,_,z) -> z)
in runReaderT (runEncodeParams encode (Nothing, "foo", 'z')) conn
:}
K Nothing :* K (Just "foo") :* K (Just "z") :* Nil

>>> finish conn
-}
(*.)
  :: forall db x x0 ty0 x1 ty1
   . ( ToParam db ty0 x0
     , ty0 ~ NullPG x0
     , ToParam db ty1 x1
     , ty1 ~ NullPG x1
     )
  => (x -> x0) -- ^ second to last
  -> (x -> x1) -- ^ last
  -> EncodeParams db '[ty0, ty1] x
x -> x0
f *. :: forall (db :: SchemasType) x x0 (ty0 :: NullType) x1
       (ty1 :: NullType).
(ToParam db ty0 x0, ty0 ~ NullPG x0, ToParam db ty1 x1,
 ty1 ~ NullPG x1) =>
(x -> x0) -> (x -> x1) -> EncodeParams db '[ty0, ty1] x
*. x -> x1
g = x -> x0
f forall (db :: SchemasType) x0 (ty :: NullType) x
       (tys :: [NullType]).
(ToParam db ty x0, ty ~ NullPG x0) =>
(x -> x0) -> EncodeParams db tys x -> EncodeParams db (ty : tys) x
.* x -> x1
g forall (db :: SchemasType) x0 (ty :: NullType) x
       (tys :: [NullType]).
(ToParam db ty x0, ty ~ NullPG x0) =>
(x -> x0) -> EncodeParams db tys x -> EncodeParams db (ty : tys) x
.* forall {k} (db :: SchemasType) x. EncodeParams db '[] x
nilParams
infixl 8 *.

{- | Encode 1 parameter.

>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
>>> :{
let
  encode :: EncodeParams '[] '[ 'NotNull 'PGint4] Int32
  encode = aParam
in runReaderT (runEncodeParams encode 1776) conn
:}
K (Just "\NUL\NUL\ACK\240") :* Nil

>>> finish conn
-}
aParam
  :: forall db x ty. (ToParam db ty x, ty ~ NullPG x)
  => EncodeParams db '[ty] x
  -- ^ a single parameter
aParam :: forall (db :: SchemasType) x (ty :: NullType).
(ToParam db ty x, ty ~ NullPG x) =>
EncodeParams db '[ty] x
aParam = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Encoding
param -> forall k a (b :: k). a -> K a b
SOP.K Maybe Encoding
param forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall {k} (a :: k -> *). NP a '[]
Nil) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) (ty :: NullType) x.
ToParam db ty x =>
x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam @db @(NullPG x)

{- | Append parameter encodings.

>>> conn <- connectdb @'[] "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
>>> :{
let
  encode :: EncodeParams '[]
    '[ 'NotNull 'PGint4, 'NotNull 'PGint2]
    (Int32, Int16)
  encode = contramap fst aParam `appendParams` contramap snd aParam
in runReaderT (runEncodeParams encode (1776, 2)) conn
:}
K (Just "\NUL\NUL\ACK\240") :* K (Just "\NUL\STX") :* Nil

>>> finish conn
-}
appendParams
  :: EncodeParams db params0 x -- ^ left
  -> EncodeParams db params1 x -- ^ right
  -> EncodeParams db (Join params0 params1) x
appendParams :: forall {k} (db :: SchemasType) (params0 :: [k]) x (params1 :: [k]).
EncodeParams db params0 x
-> EncodeParams db params1 x
-> EncodeParams db (Join params0 params1) x
appendParams EncodeParams db params0 x
encode0 EncodeParams db params1 x
encode1 = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams forall a b. (a -> b) -> a -> b
$ \x
x -> forall {a} (expr :: [a] -> *) (ys :: [a]) (xs :: [a]).
Additional expr =>
expr ys -> expr xs -> expr (Join xs ys)
also
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k (db :: SchemasType) (tys :: [k]) x.
EncodeParams db tys x
-> x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
runEncodeParams EncodeParams db params1 x
encode1 x
x
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall k (db :: SchemasType) (tys :: [k]) x.
EncodeParams db tys x
-> x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
runEncodeParams EncodeParams db params0 x
encode0 x
x

{- |
>>> :set -XLambdaCase -XFlexibleInstances
>>> :{
data Dir = North | South | East | West
instance IsPG Dir where
  type PG Dir = 'PGenum '["north", "south", "east", "west"]
instance ToPG db Dir where
  toPG = enumParam $ \case
    North -> label @"north"
    South -> label @"south"
    East -> label @"east"
    West -> label @"west"
:}
-}
enumParam
  :: (PG x ~ 'PGenum labels, SOP.All KnownSymbol labels)
  => (x -> SOP.NS PGlabel labels)
  -- ^ match cases with enum `label`s
  -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding)
enumParam :: forall {k} x (labels :: [ConstructorName]) (db :: k).
(PG x ~ 'PGenum labels, All KnownSymbol labels) =>
(x -> NS PGlabel labels)
-> x -> ReaderT (K Connection db) IO Encoding
enumParam x -> NS PGlabel labels
casesOf
  = forall (m :: * -> *) a. Monad m => a -> m a
return
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
text_strict
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Strict.Text.pack
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (lbls :: [ConstructorName]).
All KnownSymbol lbls =>
NS PGlabel lbls -> String
enumCases
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> NS PGlabel labels
casesOf
  where
    enumCases
      :: SOP.All KnownSymbol lbls
      => SOP.NS PGlabel lbls
      -> String
    enumCases :: forall (lbls :: [ConstructorName]).
All KnownSymbol lbls =>
NS PGlabel lbls -> String
enumCases = \case
      SOP.Z (PGlabel x
_ :: PGlabel lbl) -> forall (n :: ConstructorName) (proxy :: ConstructorName -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
SOP.Proxy @lbl)
      SOP.S NS PGlabel xs
cases -> forall (lbls :: [ConstructorName]).
All KnownSymbol lbls =>
NS PGlabel lbls -> String
enumCases NS PGlabel xs
cases

{- |
>>> :set -XTypeFamilies -XFlexibleInstances
>>> :{
data Complex = Complex
  { real :: Double
  , imaginary :: Double
  }
instance IsPG Complex where
  type PG Complex = 'PGcomposite '[
    "re" ::: 'NotNull 'PGfloat8,
    "im" ::: 'NotNull 'PGfloat8]
instance ToPG db Complex where
  toPG = rowParam $ real `as` #re #. imaginary `as` #im
:}
-}
rowParam
  :: (PG x ~ 'PGcomposite row, SOP.All (OidOfField db) row)
  => EncodeParams db row x
  -- ^ use `(.#)` and `(#.)` to define a row parameter encoding
  -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding)
rowParam :: forall x (row :: [(ConstructorName, NullType)])
       (db :: SchemasType).
(PG x ~ 'PGcomposite row, All (OidOfField db) row) =>
EncodeParams db row x -> x -> ReaderT (K Connection db) IO Encoding
rowParam (EncodeParams db row x
enc :: EncodeParams db row x) x
x = do
  let
    compositeSize :: Encoding
compositeSize
      = Int32 -> Encoding
int4_int32
      forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral
      forall a b. (a -> b) -> a -> b
$ forall k (xs :: [k]) (proxy :: [k] -> *).
SListI xs =>
proxy xs -> Int
SOP.lengthSList
      forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
SOP.Proxy @row
    each
      :: OidOfField db field
      => SOP.K (Maybe Encoding) field
      -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding
    each :: forall (field :: (ConstructorName, NullType)).
OidOfField db field =>
K (Maybe Encoding) field -> ReaderT (K Connection db) IO Encoding
each (SOP.K Maybe Encoding
field :: SOP.K (Maybe Encoding) field) = do
      Word32
oid <- Oid -> Word32
getOid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (db :: SchemasType) (field :: (ConstructorName, NullType)).
OidOfField db field =>
ReaderT (K Connection db) IO Oid
oidOfField @db @field
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word32 -> Encoding
int4_word32 Word32
oid forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Encoding
null4 Encoding -> Encoding
sized Maybe Encoding
field
  NP (K (Maybe Encoding)) row
fields <- forall k (db :: SchemasType) (tys :: [k]) x.
EncodeParams db tys x
-> x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
runEncodeParams EncodeParams db row x
enc x
x
  Encoding
compositePayload <- forall {k} r (m :: * -> *) (c :: k -> Constraint) (xs :: [k])
       (f :: k -> *).
(Monoid r, Applicative m, All c xs) =>
Proxy c -> (forall (x :: k). c x => f x -> m r) -> NP f xs -> m r
hcfoldMapM
    (forall {k} (t :: k). Proxy t
SOP.Proxy @(OidOfField db)) forall (field :: (ConstructorName, NullType)).
OidOfField db field =>
K (Maybe Encoding) field -> ReaderT (K Connection db) IO Encoding
each NP (K (Maybe Encoding)) row
fields
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Encoding
compositeSize forall a. Semigroup a => a -> a -> a
<> Encoding
compositePayload

{- | Cons a row parameter encoding for `rowParam`. -}
(.#)
  :: forall db x0 fld ty x tys. (ToParam db ty x0, ty ~ NullPG x0)
  => Aliased ((->) x) (fld ::: x0) -- ^ head
  -> EncodeParams db tys x -- ^ tail
  -> EncodeParams db (fld ::: ty ': tys) x
(x -> ty
f `As` Alias alias
_) .# :: forall (db :: SchemasType) x0 (fld :: ConstructorName)
       (ty :: NullType) x (tys :: [(ConstructorName, NullType)]).
(ToParam db ty x0, ty ~ NullPG x0) =>
Aliased ((->) x) (fld ::: x0)
-> EncodeParams db tys x -> EncodeParams db ((fld ::: ty) : tys) x
.# EncodeParams x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
params = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams forall a b. (a -> b) -> a -> b
$ \x
x ->
  forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
(:*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k a (b :: k). a -> K a b
SOP.K forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (db :: SchemasType) (ty :: NullType) x.
ToParam db ty x =>
x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam @db @ty (x -> ty
f x
x)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys)
params x
x
infixr 5 .#

{- | End a row parameter encoding for `rowParam`. -}
(#.)
  :: forall db x x0 fld0 ty0 x1 fld1 ty1
   . ( ToParam db ty0 x0
     , ty0 ~ NullPG x0
     , ToParam db ty1 x1
     , ty1 ~ NullPG x1
     )
  => Aliased ((->) x) (fld0 ::: x0) -- ^ second to last
  -> Aliased ((->) x) (fld1 ::: x1) -- ^ last
  -> EncodeParams db '[fld0 ::: ty0, fld1 ::: ty1] x
Aliased ((->) x) (fld0 ::: x0)
f #. :: forall (db :: SchemasType) x x0 (fld0 :: ConstructorName)
       (ty0 :: NullType) x1 (fld1 :: ConstructorName) (ty1 :: NullType).
(ToParam db ty0 x0, ty0 ~ NullPG x0, ToParam db ty1 x1,
 ty1 ~ NullPG x1) =>
Aliased ((->) x) (fld0 ::: x0)
-> Aliased ((->) x) (fld1 ::: x1)
-> EncodeParams db '[fld0 ::: ty0, fld1 ::: ty1] x
#. Aliased ((->) x) (fld1 ::: x1)
g = Aliased ((->) x) (fld0 ::: x0)
f forall (db :: SchemasType) x0 (fld :: ConstructorName)
       (ty :: NullType) x (tys :: [(ConstructorName, NullType)]).
(ToParam db ty x0, ty ~ NullPG x0) =>
Aliased ((->) x) (fld ::: x0)
-> EncodeParams db tys x -> EncodeParams db ((fld ::: ty) : tys) x
.# Aliased ((->) x) (fld1 ::: x1)
g forall (db :: SchemasType) x0 (fld :: ConstructorName)
       (ty :: NullType) x (tys :: [(ConstructorName, NullType)]).
(ToParam db ty x0, ty ~ NullPG x0) =>
Aliased ((->) x) (fld ::: x0)
-> EncodeParams db tys x -> EncodeParams db ((fld ::: ty) : tys) x
.# forall {k} (db :: SchemasType) x. EncodeParams db '[] x
nilParams
infixl 8 #.

instance (ToParam db ty x, ty ~ NullPG x)
  => IsLabel fld (EncodeParams db '[fld ::: ty] x) where
    fromLabel :: EncodeParams db '[fld ::: ty] x
fromLabel
      = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams
      forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Encoding
param -> forall k a (b :: k). a -> K a b
SOP.K Maybe Encoding
param forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall {k} (a :: k -> *). NP a '[]
Nil)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (db :: SchemasType) (ty :: NullType) x.
ToParam db ty x =>
x -> ReaderT (K Connection db) IO (Maybe Encoding)
toParam @db @(NullPG x)

{- |
>>> import GHC.Generics as GHC
>>> :{
data L = L {frst :: Int16, scnd :: Char}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
data R = R {thrd :: Bool, frth :: Bool}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
instance IsPG (L,R) where
  type PG (L,R) = 'PGcomposite '[
    "frst" ::: 'NotNull 'PGint2,
    "scnd" ::: 'NotNull ('PGchar 1),
    "thrd" ::: 'NotNull 'PGbool,
    "frth" ::: 'NotNull 'PGbool]
instance ToPG db (L,R) where
  toPG = rowParam $
    contramap fst genericRowParams
    `appendParams`
    contramap snd genericRowParams
:}
-}
genericRowParams
  ::  forall db row x xs.
      ( SOP.IsRecord x xs
      , SOP.AllZip (ToField db) row xs
      )
  => EncodeParams db row x
genericRowParams :: forall (db :: SchemasType) (row :: [(ConstructorName, NullType)]) x
       (xs :: RecordCode).
(IsRecord x xs, AllZip (ToField db) row xs) =>
EncodeParams db row x
genericRowParams
  = forall k (db :: SchemasType) (tys :: [k]) x.
(x -> ReaderT (K Connection db) IO (NP (K (Maybe Encoding)) tys))
-> EncodeParams db tys x
EncodeParams
  forall a b. (a -> b) -> a -> b
$ forall {k} {k} (c :: k -> k -> Constraint) (ys :: [k]) (xs :: [k])
       (m :: * -> *) (f :: k -> *) (g :: k -> *).
(AllZip c ys xs, Applicative m) =>
Proxy c
-> (forall (y :: k) (x :: k). c y x => f x -> m (g y))
-> NP f xs
-> m (NP g ys)
hctransverse (forall {k} (t :: k). Proxy t
SOP.Proxy @(ToField db)) (forall (db :: SchemasType) (field :: (ConstructorName, NullType))
       (x :: (ConstructorName, *)).
ToField db field x =>
P x -> ReaderT (K Connection db) IO (K (Maybe Encoding) field)
toField @db)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (_r :: RecordCode). IsRecord a _r => a -> RecordRep a
SOP.toRecord

-- helper functions

getOid :: LibPQ.Oid -> Word32
getOid :: Oid -> Word32
getOid (LibPQ.Oid (CUInt Word32
oid)) = Word32
oid

encodeArray :: Int32 -> Bool -> LibPQ.Oid -> [Int32] -> Encoding -> Encoding
encodeArray :: Int32 -> Bool -> Oid -> [Int32] -> Encoding -> Encoding
encodeArray Int32
ndim Bool
nulls Oid
oid [Int32]
dimensions Encoding
payload = forall a. Monoid a => [a] -> a
mconcat
  [ Int32 -> Encoding
int4_int32 Int32
ndim
  , if Bool
nulls then Encoding
true4 else Encoding
false4
  , Word32 -> Encoding
int4_word32 (Oid -> Word32
getOid Oid
oid)
  , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Int32
dimension -> Int32 -> Encoding
int4_int32 Int32
dimension forall a. Semigroup a => a -> a -> a
<> Encoding
true4) [Int32]
dimensions
  , Encoding
payload ]

dimArray
  :: Functor m
  => (forall b. (b -> a -> m b) -> b -> c -> m b)
  -> (a -> m Encoding) -> c -> m Encoding
dimArray :: forall (m :: * -> *) a c.
Functor m =>
(forall b. (b -> a -> m b) -> b -> c -> m b)
-> (a -> m Encoding) -> c -> m Encoding
dimArray forall b. (b -> a -> m b) -> b -> c -> m b
folder a -> m Encoding
elementArray = forall b. (b -> a -> m b) -> b -> c -> m b
folder Encoding -> a -> m Encoding
step forall a. Monoid a => a
mempty
  where
    step :: Encoding -> a -> m Encoding
step Encoding
builder a
element = (Encoding
builder forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m Encoding
elementArray a
element

null4, true4, false4 :: Encoding
null4 :: Encoding
null4 = Int32 -> Encoding
int4_int32 (-Int32
1)
true4 :: Encoding
true4 = Word32 -> Encoding
int4_word32 Word32
1
false4 :: Encoding
false4 = Word32 -> Encoding
int4_word32 Word32
0

sized :: Encoding -> Encoding
sized :: Encoding -> Encoding
sized Encoding
bs = Int32 -> Encoding
int4_int32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Encoding -> Int
builderLength Encoding
bs)) forall a. Semigroup a => a -> a -> a
<> Encoding
bs

hctransverse
  :: (SOP.AllZip c ys xs, Applicative m)
  => SOP.Proxy c
  -> (forall y x. c y x => f x -> m (g y))
  -> NP f xs -> m (NP g ys)
hctransverse :: forall {k} {k} (c :: k -> k -> Constraint) (ys :: [k]) (xs :: [k])
       (m :: * -> *) (f :: k -> *) (g :: k -> *).
(AllZip c ys xs, Applicative m) =>
Proxy c
-> (forall (y :: k) (x :: k). c y x => f x -> m (g y))
-> NP f xs
-> m (NP g ys)
hctransverse Proxy c
c forall (y :: k) (x :: k). c y x => f x -> m (g y)
f = \case
  NP f xs
Nil -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (a :: k -> *). NP a '[]
Nil
  f x
x :* NP f xs
xs -> forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
(:*) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (y :: k) (x :: k). c y x => f x -> m (g y)
f f x
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} {k} (c :: k -> k -> Constraint) (ys :: [k]) (xs :: [k])
       (m :: * -> *) (f :: k -> *) (g :: k -> *).
(AllZip c ys xs, Applicative m) =>
Proxy c
-> (forall (y :: k) (x :: k). c y x => f x -> m (g y))
-> NP f xs
-> m (NP g ys)
hctransverse Proxy c
c forall (y :: k) (x :: k). c y x => f x -> m (g y)
f NP f xs
xs

hcfoldMapM
  :: (Monoid r, Applicative m, SOP.All c xs)
  => SOP.Proxy c
  -> (forall x. c x => f x -> m r)
  -> NP f xs -> m r
hcfoldMapM :: forall {k} r (m :: * -> *) (c :: k -> Constraint) (xs :: [k])
       (f :: k -> *).
(Monoid r, Applicative m, All c xs) =>
Proxy c -> (forall (x :: k). c x => f x -> m r) -> NP f xs -> m r
hcfoldMapM Proxy c
c forall (x :: k). c x => f x -> m r
f = \case
  NP f xs
Nil -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  f x
x :* NP f xs
xs -> forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (x :: k). c x => f x -> m r
f f x
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} r (m :: * -> *) (c :: k -> Constraint) (xs :: [k])
       (f :: k -> *).
(Monoid r, Applicative m, All c xs) =>
Proxy c -> (forall (x :: k). c x => f x -> m r) -> NP f xs -> m r
hcfoldMapM Proxy c
c forall (x :: k). c x => f x -> m r
f NP f xs
xs