squeal-postgresql-0.9.2.0: src/Squeal/PostgreSQL/Session/Encode.hs

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

encoding of statement parameters
-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  >>> finish conn
  -}
  genericParams :: EncodeParams db params x
instance
  ( params ~ TuplePG x
  , SOP.All (OidOfNull db) params
  , SOP.IsProductType x xs
  , SOP.AllZip (ToParam db) params xs
  ) => GenericParams db params x xs where
  genericParams = EncodeParams
    $ hctransverse (SOP.Proxy @(ToParam db)) encodeNullParam
    . SOP.unZ . SOP.unSOP . SOP.from
    where
      encodeNullParam
        :: forall ty y. ToParam db ty y
        => SOP.I y -> ReaderT (SOP.K LibPQ.Connection db) IO (SOP.K (Maybe Encoding) ty)
      encodeNullParam = fmap SOP.K . toParam @db @ty . SOP.unI

-- | Encode 0 parameters.
nilParams :: EncodeParams db '[] x
nilParams = EncodeParams $ \ _ -> pure Nil

{- | Cons a parameter encoding.

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

>>> finish conn
-}
(.*)
  :: forall db x0 ty x tys. (ToParam db ty x0, ty ~ NullPG x0)
  => (x -> x0) -- ^ head
  -> EncodeParams db tys x -- ^ tail
  -> EncodeParams db (ty ': tys) x
f .* EncodeParams params = EncodeParams $ \x ->
  (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x
infixr 5 .*

{- | End a parameter encoding.

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

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

{- | Encode 1 parameter.

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

>>> finish conn
-}
aParam
  :: forall db x ty. (ToParam db ty x, ty ~ NullPG x)
  => EncodeParams db '[ty] x
  -- ^ a single parameter
aParam = EncodeParams $
  fmap (\param -> SOP.K param :* Nil) . toParam @db @(NullPG x)

{- | Append parameter encodings.

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

>>> finish conn
-}
appendParams
  :: EncodeParams db params0 x -- ^ left
  -> EncodeParams db params1 x -- ^ right
  -> EncodeParams db (Join params0 params1) x
appendParams encode0 encode1 = EncodeParams $ \x -> also
  <$> runEncodeParams encode1 x
  <*> runEncodeParams encode0 x

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

{- |
>>> :set -XTypeFamilies -XFlexibleInstances
>>> :{
data Complex = Complex
  { real :: Double
  , imaginary :: Double
  }
instance IsPG Complex where
  type PG Complex = 'PGcomposite '[
    "re" ::: 'NotNull 'PGfloat8,
    "im" ::: 'NotNull 'PGfloat8]
instance ToPG db Complex where
  toPG = rowParam $ real `as` #re #. imaginary `as` #im
:}
-}
rowParam
  :: (PG x ~ 'PGcomposite row, SOP.All (OidOfField db) row)
  => EncodeParams db row x
  -- ^ use `(.#)` and `(#.)` to define a row parameter encoding
  -> (x -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding)
rowParam (enc :: EncodeParams db row x) x = do
  let
    compositeSize
      = int4_int32
      $ fromIntegral
      $ SOP.lengthSList
      $ SOP.Proxy @row
    each
      :: OidOfField db field
      => SOP.K (Maybe Encoding) field
      -> ReaderT (SOP.K LibPQ.Connection db) IO Encoding
    each (SOP.K field :: SOP.K (Maybe Encoding) field) = do
      oid <- getOid <$> oidOfField @db @field
      return $ int4_word32 oid <> maybe null4 sized field
  fields <- runEncodeParams enc x
  compositePayload <- hcfoldMapM
    (SOP.Proxy @(OidOfField db)) each fields
  return $ compositeSize <> compositePayload

{- | Cons a row parameter encoding for `rowParam`. -}
(.#)
  :: forall db x0 fld ty x tys. (ToParam db ty x0, ty ~ NullPG x0)
  => Aliased ((->) x) (fld ::: x0) -- ^ head
  -> EncodeParams db tys x -- ^ tail
  -> EncodeParams db (fld ::: ty ': tys) x
(f `As` _) .# EncodeParams params = EncodeParams $ \x ->
  (:*) <$> (SOP.K <$> toParam @db @ty (f x)) <*> params x
infixr 5 .#

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

instance (ToParam db ty x, ty ~ NullPG x)
  => IsLabel fld (EncodeParams db '[fld ::: ty] x) where
    fromLabel
      = EncodeParams
      $ fmap (\param -> SOP.K param :* Nil)
      . toParam @db @(NullPG x)

{- |
>>> import GHC.Generics as GHC
>>> :{
data L = L {frst :: Int16, scnd :: Char}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
data R = R {thrd :: Bool, frth :: Bool}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
instance IsPG (L,R) where
  type PG (L,R) = 'PGcomposite '[
    "frst" ::: 'NotNull 'PGint2,
    "scnd" ::: 'NotNull ('PGchar 1),
    "thrd" ::: 'NotNull 'PGbool,
    "frth" ::: 'NotNull 'PGbool]
instance ToPG db (L,R) where
  toPG = rowParam $
    contramap fst genericRowParams
    `appendParams`
    contramap snd genericRowParams
:}
-}
genericRowParams
  ::  forall db row x xs.
      ( SOP.IsRecord x xs
      , SOP.AllZip (ToField db) row xs
      )
  => EncodeParams db row x
genericRowParams
  = EncodeParams
  $ hctransverse (SOP.Proxy @(ToField db)) (toField @db)
  . SOP.toRecord

-- helper functions

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

encodeArray :: Int32 -> Bool -> LibPQ.Oid -> [Int32] -> Encoding -> Encoding
encodeArray ndim nulls oid dimensions payload = mconcat
  [ int4_int32 ndim
  , if nulls then true4 else false4
  , int4_word32 (getOid oid)
  , foldMap (\dimension -> int4_int32 dimension <> true4) dimensions
  , payload ]

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

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

sized :: Encoding -> Encoding
sized bs = int4_int32 (fromIntegral (builderLength bs)) <> bs

hctransverse
  :: (SOP.AllZip c ys xs, Applicative m)
  => SOP.Proxy c
  -> (forall y x. c y x => f x -> m (g y))
  -> NP f xs -> m (NP g ys)
hctransverse c f = \case
  Nil -> pure Nil
  x :* xs -> (:*) <$> f x <*> hctransverse c f xs

hcfoldMapM
  :: (Monoid r, Applicative m, SOP.All c xs)
  => SOP.Proxy c
  -> (forall x. c x => f x -> m r)
  -> NP f xs -> m r
hcfoldMapM c f = \case
  Nil -> pure mempty
  x :* xs -> (<>) <$> f x <*> hcfoldMapM c f xs