{-|
Module: Squeal.PostgreSQL.Session.Decode
Description: decoding of result values
Copyright: (c) Eitan Chatav, 2019
Maintainer: eitan@morphism.tech
Stability: experimental

decoding of result values
-}

{-# LANGUAGE
    AllowAmbiguousTypes
  , CPP
  , DataKinds
  , DerivingStrategies
  , FlexibleContexts
  , FlexibleInstances
  , FunctionalDependencies
  , GeneralizedNewtypeDeriving
  , LambdaCase
  , MultiParamTypeClasses
  , OverloadedStrings
  , PolyKinds
  , ScopedTypeVariables
  , TypeApplications
  , TypeFamilies
  , TypeOperators
  , UndecidableInstances
  , UndecidableSuperClasses
#-}

module Squeal.PostgreSQL.Session.Decode
  ( -- * Decode Types
    FromPG (..)
  , devalue
  , rowValue
  , enumValue
    -- * Decode Rows
  , DecodeRow (..)
  , decodeRow
  , runDecodeRow
  , GenericRow (..)
  , genericProductRow
  , appendRows
  , consRow
    -- * Decoding Classes
  , FromValue (..)
  , FromField (..)
  , FromAliasedValue (..)
  , FromArray (..)
  , StateT (..)
  , ExceptT (..)
  ) where

import BinaryParser
import Control.Applicative
import Control.Arrow
import Control.Monad
#if MIN_VERSION_base(4,13,0)
#else
import Control.Monad.Fail
#endif
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Maybe
import Data.Bits
import Data.Coerce (coerce)
import Data.Functor.Constant (Constant(Constant))
import Data.Int (Int16, Int32, Int64)
import Data.Kind
import Data.Scientific (Scientific)
import Data.String (fromString)
import Data.Text (Text)
import Data.Time (Day, TimeOfDay, TimeZone, LocalTime, UTCTime, DiffTime)
import Data.UUID.Types (UUID)
import Data.Vector (Vector)
import Database.PostgreSQL.LibPQ (Oid(Oid))
import GHC.OverloadedLabels
import GHC.TypeLits
import Network.IP.Addr (NetAddr, IP)
import PostgreSQL.Binary.Decoding hiding (Composite)
import Unsafe.Coerce

import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.Text.Lazy as Lazy (Text)
import qualified Data.Text as Strict (Text)
import qualified Data.Text as Strict.Text
import qualified Data.Vector as Vector
import qualified Generics.SOP as SOP
import qualified Generics.SOP.Record as SOP

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

-- | Converts a `Value` type from @postgresql-binary@ for use in
-- the `fromPG` method of `FromPG`.
devalue :: Value x -> StateT Strict.ByteString (Except Strict.Text) x
devalue :: forall x. Value x -> StateT ByteString (Except Text) x
devalue = forall a b. a -> b
unsafeCoerce

revalue :: StateT Strict.ByteString (Except Strict.Text) x -> Value x
revalue :: forall x. StateT ByteString (Except Text) x -> Value x
revalue = forall a b. a -> b
unsafeCoerce

{- |
>>> :set -XTypeFamilies
>>> :{
data Complex = Complex
  { real :: Double
  , imaginary :: Double
  }
instance IsPG Complex where
  type PG Complex = 'PGcomposite '[
    "re" ::: 'NotNull 'PGfloat8,
    "im" ::: 'NotNull 'PGfloat8]
instance FromPG Complex where
  fromPG = rowValue $ do
    re <- #re
    im <- #im
    return Complex {real = re, imaginary = im}
:}
-}
rowValue
  :: (PG y ~ 'PGcomposite row, SOP.SListI row)
  => DecodeRow row y -- ^ fields
  -> StateT Strict.ByteString (Except Strict.Text) y
rowValue :: forall y (row :: RowType).
(PG y ~ 'PGcomposite row, SListI row) =>
DecodeRow row y -> StateT ByteString (Except Text) y
rowValue DecodeRow row y
decoder = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$
  let
    -- <number of fields: 4 bytes>
    -- [for each field]
    --  <OID of field's type: sizeof(Oid) bytes>
    --  [if value is NULL]
    --    <-1: 4 bytes>
    --  [else]
    --    <length of value: 4 bytes>
    --    <value: <length> bytes>
    --  [end if]
    -- [end for]
    comp :: ByteString -> Either Text (NP (K (Maybe ByteString)) row)
comp = forall a. Value a -> ByteString -> Either Text a
valueParser forall a b. (a -> b) -> a -> b
$ do
      Int -> BinaryParser ()
unitOfSize Int
4
      forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
SOP.hsequence' forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
SOP.hpure forall a b. (a -> b) -> a -> b
$ forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp forall a b. (a -> b) -> a -> b
$ do
        Int -> BinaryParser ()
unitOfSize Int
4
        Int32
len :: Int32 <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 forall a. (Integral a, Bits a) => Value a
int
        if Int32
len forall a. Eq a => a -> a -> Bool
== -Int32
1
          then forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a (b :: k). a -> K a b
SOP.K forall a. Maybe a
Nothing)
          else forall k a (b :: k). a -> K a b
SOP.K forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BinaryParser ByteString
bytesOfSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  in forall a. (ByteString -> Either Text a) -> Value a
fn (forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow row y
decoder forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either Text (NP (K (Maybe ByteString)) row)
comp)

-- | A `FromPG` constraint gives a parser from the binary format of
-- a PostgreSQL `PGType` into a Haskell `Type`.
class IsPG y => FromPG y where
  {- |
  >>> :set -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XDerivingStrategies -XDerivingVia -XUndecidableInstances
  >>> import GHC.Generics as GHC
  >>> :{
  newtype UserId = UserId { getId :: Int64 }
    deriving newtype (IsPG, FromPG)
  :}

  >>> :{
  data Complex = Complex
    { real :: Double
    , imaginary :: Double
    } deriving stock GHC.Generic
      deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
      deriving (IsPG, FromPG) via Composite Complex
  :}

  >>> :{
  data Direction = North | South | East | West
    deriving stock GHC.Generic
    deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
    deriving (IsPG, FromPG) via Enumerated Direction
  :}

  -}
  fromPG :: StateT Strict.ByteString (Except Strict.Text) y
instance FromPG Bool where
  fromPG :: StateT ByteString (Except Text) Bool
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Bool
bool
instance FromPG Int16 where
  fromPG :: StateT ByteString (Except Text) Int16
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a. (Integral a, Bits a) => Value a
int
instance FromPG Int32 where
  fromPG :: StateT ByteString (Except Text) Int32
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a. (Integral a, Bits a) => Value a
int
instance FromPG Int64 where
  fromPG :: StateT ByteString (Except Text) Int64
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a. (Integral a, Bits a) => Value a
int
instance FromPG Oid where
  fromPG :: StateT ByteString (Except Text) Oid
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ CUInt -> Oid
Oid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, Bits a) => Value a
int
instance FromPG Float where
  fromPG :: StateT ByteString (Except Text) Float
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Float
float4
instance FromPG Double where
  fromPG :: StateT ByteString (Except Text) Double
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Double
float8
instance FromPG Scientific where
  fromPG :: StateT ByteString (Except Text) Scientific
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Scientific
numeric
instance FromPG Money where
  fromPG :: StateT ByteString (Except Text) Money
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$  Int64 -> Money
Money forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, Bits a) => Value a
int
instance FromPG UUID where
  fromPG :: StateT ByteString (Except Text) UUID
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value UUID
uuid
instance FromPG (NetAddr IP) where
  fromPG :: StateT ByteString (Except Text) (NetAddr IP)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value (NetAddr IP)
inet
instance FromPG Char where
  fromPG :: StateT ByteString (Except Text) Char
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Char
char
instance FromPG Strict.Text where
  fromPG :: StateT ByteString (Except Text) Text
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Text
text_strict
instance FromPG Lazy.Text where
  fromPG :: StateT ByteString (Except Text) Text
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Text
text_lazy
instance FromPG String where
  fromPG :: StateT ByteString (Except Text) String
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ Text -> String
Strict.Text.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value Text
text_strict
instance FromPG Strict.ByteString where
  fromPG :: StateT ByteString (Except Text) ByteString
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue BinaryParser ByteString
bytea_strict
instance FromPG Lazy.ByteString where
  fromPG :: StateT ByteString (Except Text) ByteString
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value ByteString
bytea_lazy
instance KnownNat n => FromPG (VarChar n) where
  fromPG :: StateT ByteString (Except Text) (VarChar n)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ Value Text
text_strict forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t ->
    case forall (n :: Nat). KnownNat n => Text -> Maybe (VarChar n)
varChar Text
t of
      Maybe (VarChar n)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Text
Strict.Text.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Source for VarChar has wrong length"
        , String
"; expected length "
        , forall a. Show a => a -> String
show (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
SOP.Proxy @n))
        , String
", actual length "
        , forall a. Show a => a -> String
show (Text -> Int
Strict.Text.length Text
t)
        , String
"."
        ]
      Just VarChar n
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure VarChar n
x
instance KnownNat n => FromPG (FixChar n) where
  fromPG :: StateT ByteString (Except Text) (FixChar n)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ Value Text
text_strict forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t ->
    case forall (n :: Nat). KnownNat n => Text -> Maybe (FixChar n)
fixChar Text
t of
      Maybe (FixChar n)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Text
Strict.Text.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Source for FixChar has wrong length"
        , String
"; expected length "
        , forall a. Show a => a -> String
show (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
SOP.Proxy @n))
        , String
", actual length "
        , forall a. Show a => a -> String
show (Text -> Int
Strict.Text.length Text
t)
        , String
"."
        ]
      Just FixChar n
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FixChar n
x
instance FromPG x => FromPG (Const x tag) where
  fromPG :: StateT ByteString (Except Text) (Const x tag)
fromPG = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall y. FromPG y => StateT ByteString (Except Text) y
fromPG @x
instance FromPG x => FromPG (SOP.K x tag) where
  fromPG :: StateT ByteString (Except Text) (K x tag)
fromPG = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall y. FromPG y => StateT ByteString (Except Text) y
fromPG @x
instance FromPG x => FromPG (Constant x tag) where
  fromPG :: StateT ByteString (Except Text) (Constant x tag)
fromPG = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall y. FromPG y => StateT ByteString (Except Text) y
fromPG @x
instance FromPG Day where
  fromPG :: StateT ByteString (Except Text) Day
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Day
date
instance FromPG TimeOfDay where
  fromPG :: StateT ByteString (Except Text) TimeOfDay
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value TimeOfDay
time_int
instance FromPG (TimeOfDay, TimeZone) where
  fromPG :: StateT ByteString (Except Text) (TimeOfDay, TimeZone)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value (TimeOfDay, TimeZone)
timetz_int
instance FromPG LocalTime where
  fromPG :: StateT ByteString (Except Text) LocalTime
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value LocalTime
timestamp_int
instance FromPG UTCTime where
  fromPG :: StateT ByteString (Except Text) UTCTime
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value UTCTime
timestamptz_int
instance FromPG DiffTime where
  fromPG :: StateT ByteString (Except Text) DiffTime
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value DiffTime
interval_int
instance FromPG Aeson.Value where
  fromPG :: StateT ByteString (Except Text) Value
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Value
json_ast
instance Aeson.FromJSON x => FromPG (Json x) where
  fromPG :: StateT ByteString (Except Text) (Json x)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ forall hask. hask -> Json hask
Json forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a. (ByteString -> Either Text a) -> Value a
json_bytes (forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left String -> Text
Strict.Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict)
instance Aeson.FromJSON x => FromPG (Jsonb x) where
  fromPG :: StateT ByteString (Except Text) (Jsonb x)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ forall hask. hask -> Jsonb hask
Jsonb forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a. (ByteString -> Either Text a) -> Value a
jsonb_bytes (forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left String -> Text
Strict.Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict)
instance (FromArray '[] ty y, ty ~ NullPG y)
  => FromPG (VarArray (Vector y)) where
    fromPG :: StateT ByteString (Except Text) (VarArray (Vector y))
fromPG =
      let
        rep :: Int -> f a -> f (VarArray (Vector a))
rep Int
n f a
x = forall arr. arr -> VarArray arr
VarArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
n f a
x
      in
        forall x. Value x -> StateT ByteString (Except Text) x
devalue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Array a -> Value a
array forall a b. (a -> b) -> a -> b
$ forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall {f :: * -> *} {a}.
Monad f =>
Int -> f a -> f (VarArray (Vector a))
rep
          (forall (dims :: [Nat]) (ty :: NullType) y.
FromArray dims ty y =>
Array y
fromArray @'[] @(NullPG y))
instance (FromArray '[] ty y, ty ~ NullPG y)
  => FromPG (VarArray [y]) where
    fromPG :: StateT ByteString (Except Text) (VarArray [y])
fromPG =
      let
        rep :: Int -> f a -> f (VarArray [a])
rep Int
n f a
x = forall arr. arr -> VarArray arr
VarArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n f a
x
      in
        forall x. Value x -> StateT ByteString (Except Text) x
devalue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Array a -> Value a
array forall a b. (a -> b) -> a -> b
$ forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall {f :: * -> *} {a}.
Applicative f =>
Int -> f a -> f (VarArray [a])
rep
          (forall (dims :: [Nat]) (ty :: NullType) y.
FromArray dims ty y =>
Array y
fromArray @'[] @(NullPG y))
instance FromArray dims ty y => FromPG (FixArray y) where
  fromPG :: StateT ByteString (Except Text) (FixArray y)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ forall arr. arr -> FixArray arr
FixArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Array a -> Value a
array (forall (dims :: [Nat]) (ty :: NullType) y.
FromArray dims ty y =>
Array y
fromArray @dims @ty @y)
instance
  ( SOP.IsEnumType y
  , SOP.HasDatatypeInfo y
  , LabelsPG y ~ labels
  ) => FromPG (Enumerated y) where
    fromPG :: StateT ByteString (Except Text) (Enumerated y)
fromPG =
      let
        greadConstructor
          :: SOP.All ((~) '[]) xss
          => NP SOP.ConstructorInfo xss
          -> String
          -> Maybe (SOP.SOP SOP.I xss)
        greadConstructor :: forall (xss :: [[*]]).
All ((~) '[]) xss =>
NP ConstructorInfo xss -> String -> Maybe (SOP I xss)
greadConstructor NP ConstructorInfo xss
Nil String
_ = forall a. Maybe a
Nothing
        greadConstructor (ConstructorInfo x
constructor :* NP ConstructorInfo xs
constructors) String
name =
          if String
name forall a. Eq a => a -> a -> Bool
== forall (xs :: [*]). ConstructorInfo xs -> String
SOP.constructorName ConstructorInfo x
constructor
            then forall a. a -> Maybe a
Just (forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP (forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
SOP.Z forall {k} (a :: k -> *). NP a '[]
Nil))
            else forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
SOP.S 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              forall (xss :: [[*]]).
All ((~) '[]) xss =>
NP ConstructorInfo xss -> String -> Maybe (SOP I xss)
greadConstructor NP ConstructorInfo xs
constructors String
name
      in
        forall x. Value x -> StateT ByteString (Except Text) x
devalue
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall enum. enum -> Enumerated enum
Enumerated
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Text -> Maybe a) -> Value a
enum
        forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Generic a => Rep a -> a
SOP.to
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xss :: [[*]]).
All ((~) '[]) xss =>
NP ConstructorInfo xss -> String -> Maybe (SOP I xss)
greadConstructor
          (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 @y)))
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Strict.Text.unpack
instance
  ( SOP.IsRecord y ys
  , SOP.AllZip FromField row ys
  , RowPG y ~ row
  ) => FromPG (Composite y) where
    fromPG :: StateT ByteString (Except Text) (Composite y)
fromPG = forall y (row :: RowType).
(PG y ~ 'PGcomposite row, SListI row) =>
DecodeRow row y -> StateT ByteString (Except Text) y
rowValue (forall record. record -> Composite record
Composite forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (row :: RowType) y (ys :: RecordCode).
GenericRow row y ys =>
DecodeRow row y
genericRow)
instance FromPG y => FromPG (Range y) where
  fromPG :: StateT ByteString (Except Text) (Range y)
fromPG = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall a b. (a -> b) -> a -> b
$ do
    Word8
flag <- BinaryParser Word8
byte
    if forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
0 then forall (m :: * -> *) a. Monad m => a -> m a
return forall x. Range x
Empty else do
      Bound y
lower <-
        if forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
3
          then forall (m :: * -> *) a. Monad m => a -> m a
return forall x. Bound x
Infinite
          else do
            Int
len <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 forall a. (Integral a, Bits a) => Value a
int
            y
l <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
len (forall x. StateT ByteString (Except Text) x -> Value x
revalue forall y. FromPG y => StateT ByteString (Except Text) y
fromPG)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
1 then forall x. x -> Bound x
Closed y
l else forall x. x -> Bound x
Open y
l
      Bound y
upper <-
        if forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
4
          then forall (m :: * -> *) a. Monad m => a -> m a
return forall x. Bound x
Infinite
          else do
            Int
len <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 forall a. (Integral a, Bits a) => Value a
int
            y
l <- forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
len (forall x. StateT ByteString (Except Text) x -> Value x
revalue forall y. FromPG y => StateT ByteString (Except Text) y
fromPG)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
2 then forall x. x -> Bound x
Closed y
l else forall x. x -> Bound x
Open y
l
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. Bound x -> Bound x -> Range x
NonEmpty Bound y
lower Bound y
upper

-- | A `FromValue` constraint lifts the `FromPG` parser
-- to a decoding of a @NullityType@ to a `Type`,
-- decoding `Null`s to `Maybe`s. You should not define instances for
-- `FromValue`, just use the provided instances.
class FromValue (ty :: NullType) (y :: Type) where
  fromValue :: Maybe Strict.ByteString -> Either Strict.Text y
instance (FromPG y, pg ~ PG y) => FromValue ('NotNull pg) y where
  fromValue :: Maybe ByteString -> Either Text y
fromValue = \case
    Maybe ByteString
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"fromField: saw NULL when expecting NOT NULL"
    Just ByteString
bytestring -> forall a. Value a -> ByteString -> Either Text a
valueParser (forall x. StateT ByteString (Except Text) x -> Value x
revalue forall y. FromPG y => StateT ByteString (Except Text) y
fromPG) ByteString
bytestring
instance (FromPG y, pg ~ PG y) => FromValue ('Null pg) (Maybe y) where
  fromValue :: Maybe ByteString -> Either Text (Maybe y)
fromValue = \case
    Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just ByteString
bytestring -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Value a -> ByteString -> Either Text a
valueParser (forall x. StateT ByteString (Except Text) x -> Value x
revalue forall y. FromPG y => StateT ByteString (Except Text) y
fromPG) ByteString
bytestring

-- | A `FromField` constraint lifts the `FromPG` parser
-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,
-- decoding `Null`s to `Maybe`s. You should not define instances for
-- `FromField`, just use the provided instances.
class FromField (field :: (Symbol, NullType)) (y :: (Symbol, Type)) where
  fromField :: Maybe Strict.ByteString -> Either Strict.Text (SOP.P y)
instance (FromValue ty y, fld0 ~ fld1)
  => FromField (fld0 ::: ty) (fld1 ::: y) where
    fromField :: Maybe ByteString -> Either Text (P (fld1 ::: y))
fromField = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (p :: (a, *)). Snd p -> P p
SOP.P forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
fromValue @ty

-- | A `FromArray` constraint gives a decoding to a Haskell `Type`
-- from the binary format of a PostgreSQL fixed-length array.
-- You should not define instances for
-- `FromArray`, just use the provided instances.
class FromArray (dims :: [Nat]) (ty :: NullType) (y :: Type) where
  fromArray :: Array y
instance (FromPG y, pg ~ PG y) => FromArray '[] ('NotNull pg) y where
  fromArray :: Array y
fromArray = forall a. Value a -> Array a
valueArray (forall x. StateT ByteString (Except Text) x -> Value x
revalue forall y. FromPG y => StateT ByteString (Except Text) y
fromPG)
instance (FromPG y, pg ~ PG y) => FromArray '[] ('Null pg) (Maybe y) where
  fromArray :: Array (Maybe y)
fromArray = forall a. Value a -> Array (Maybe a)
nullableValueArray (forall x. StateT ByteString (Except Text) x -> Value x
revalue forall y. FromPG y => StateT ByteString (Except Text) y
fromPG)
instance
  ( SOP.IsProductType product ys
  , Length ys ~ dim
  , SOP.All ((~) y) ys
  , FromArray dims ty y )
  => FromArray (dim ': dims) ty product where
    fromArray :: Array product
fromArray =
      let
        rep :: p -> f x -> f b
rep p
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Generic a => Rep a -> a
SOP.to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
SOP.Z) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x (xs :: [*]) (m :: * -> *).
(All ((~) x) xs, Monad m, SListI xs) =>
m x -> m (NP I xs)
replicateMN
      in
        forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall {b} {x :: [*]} {xs :: [[*]]} {f :: * -> *} {x} {p}.
(Code b ~ (x : xs), Generic b, Monad f, All ((~) x) x) =>
p -> f x -> f b
rep (forall (dims :: [Nat]) (ty :: NullType) y.
FromArray dims ty y =>
Array y
fromArray @dims @ty @y)

replicateMN
  :: forall x xs m. (SOP.All ((~) x) xs, Monad m, SOP.SListI xs)
  => m x -> m (SOP.NP SOP.I xs)
replicateMN :: forall x (xs :: [*]) (m :: * -> *).
(All ((~) x) xs, Monad m, SListI xs) =>
m x -> m (NP I xs)
replicateMN m x
mx = forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
SOP.hsequence' forall a b. (a -> b) -> a -> b
$
  forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HPure h, AllN h c xs) =>
proxy c -> (forall (a :: k). c a => f a) -> h f xs
SOP.hcpure (forall {k} (t :: k). Proxy t
SOP.Proxy :: SOP.Proxy ((~) x)) (forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp (forall a. a -> I a
SOP.I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m x
mx))

{- |
`DecodeRow` describes a decoding of a PostgreSQL `RowType`
into a Haskell `Type`.

`DecodeRow` has an interface given by the classes
`Functor`, `Applicative`, `Alternative`, `Monad`,
`MonadPlus`, `MonadError` `Strict.Text`, and `IsLabel`.

>>> :set -XOverloadedLabels
>>> :{
let
  decode :: DecodeRow
    '[ "fst" ::: 'NotNull 'PGint2, "snd" ::: 'NotNull ('PGchar 1)]
    (Int16, Char)
  decode = (,) <$> #fst <*> #snd
in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)
:}
Right (1,'a')

There is also an `IsLabel` instance for `MaybeT` `DecodeRow`s, useful
for decoding outer joined rows.

>>> :{
let
  decode :: DecodeRow
    '[ "fst" ::: 'Null 'PGint2, "snd" ::: 'Null ('PGchar 1)]
    (Maybe (Int16, Char))
  decode = runMaybeT $ (,) <$> #fst <*> #snd
in runDecodeRow decode (SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)
:}
Right (Just (1,'a'))

-}
newtype DecodeRow (row :: RowType) (y :: Type) = DecodeRow
  { forall (row :: RowType) y.
DecodeRow row y
-> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
unDecodeRow :: ReaderT
      (SOP.NP (SOP.K (Maybe Strict.ByteString)) row) (Except Strict.Text) y }
  deriving newtype
    ( forall (row :: RowType) a b.
a -> DecodeRow row b -> DecodeRow row a
forall (row :: RowType) a b.
(a -> b) -> DecodeRow row a -> DecodeRow row b
forall a b. a -> DecodeRow row b -> DecodeRow row a
forall a b. (a -> b) -> DecodeRow row a -> DecodeRow row b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DecodeRow row b -> DecodeRow row a
$c<$ :: forall (row :: RowType) a b.
a -> DecodeRow row b -> DecodeRow row a
fmap :: forall a b. (a -> b) -> DecodeRow row a -> DecodeRow row b
$cfmap :: forall (row :: RowType) a b.
(a -> b) -> DecodeRow row a -> DecodeRow row b
Functor
    , forall (row :: RowType). Functor (DecodeRow row)
forall (row :: RowType) a. a -> DecodeRow row a
forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row a
forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row b
forall (row :: RowType) a b.
DecodeRow row (a -> b) -> DecodeRow row a -> DecodeRow row b
forall (row :: RowType) a b c.
(a -> b -> c)
-> DecodeRow row a -> DecodeRow row b -> DecodeRow row c
forall a. a -> DecodeRow row a
forall a b. DecodeRow row a -> DecodeRow row b -> DecodeRow row a
forall a b. DecodeRow row a -> DecodeRow row b -> DecodeRow row b
forall a b.
DecodeRow row (a -> b) -> DecodeRow row a -> DecodeRow row b
forall a b c.
(a -> b -> c)
-> DecodeRow row a -> DecodeRow row b -> DecodeRow row c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. DecodeRow row a -> DecodeRow row b -> DecodeRow row a
$c<* :: forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row a
*> :: forall a b. DecodeRow row a -> DecodeRow row b -> DecodeRow row b
$c*> :: forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row b
liftA2 :: forall a b c.
(a -> b -> c)
-> DecodeRow row a -> DecodeRow row b -> DecodeRow row c
$cliftA2 :: forall (row :: RowType) a b c.
(a -> b -> c)
-> DecodeRow row a -> DecodeRow row b -> DecodeRow row c
<*> :: forall a b.
DecodeRow row (a -> b) -> DecodeRow row a -> DecodeRow row b
$c<*> :: forall (row :: RowType) a b.
DecodeRow row (a -> b) -> DecodeRow row a -> DecodeRow row b
pure :: forall a. a -> DecodeRow row a
$cpure :: forall (row :: RowType) a. a -> DecodeRow row a
Applicative
    , forall (row :: RowType). Applicative (DecodeRow row)
forall (row :: RowType) a. DecodeRow row a
forall (row :: RowType) a. DecodeRow row a -> DecodeRow row [a]
forall (row :: RowType) a.
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
forall a. DecodeRow row a
forall a. DecodeRow row a -> DecodeRow row [a]
forall a. DecodeRow row a -> DecodeRow row a -> DecodeRow row a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. DecodeRow row a -> DecodeRow row [a]
$cmany :: forall (row :: RowType) a. DecodeRow row a -> DecodeRow row [a]
some :: forall a. DecodeRow row a -> DecodeRow row [a]
$csome :: forall (row :: RowType) a. DecodeRow row a -> DecodeRow row [a]
<|> :: forall a. DecodeRow row a -> DecodeRow row a -> DecodeRow row a
$c<|> :: forall (row :: RowType) a.
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
empty :: forall a. DecodeRow row a
$cempty :: forall (row :: RowType) a. DecodeRow row a
Alternative
    , forall (row :: RowType). Applicative (DecodeRow row)
forall (row :: RowType) a. a -> DecodeRow row a
forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row b
forall (row :: RowType) a b.
DecodeRow row a -> (a -> DecodeRow row b) -> DecodeRow row b
forall a. a -> DecodeRow row a
forall a b. DecodeRow row a -> DecodeRow row b -> DecodeRow row b
forall a b.
DecodeRow row a -> (a -> DecodeRow row b) -> DecodeRow row b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> DecodeRow row a
$creturn :: forall (row :: RowType) a. a -> DecodeRow row a
>> :: forall a b. DecodeRow row a -> DecodeRow row b -> DecodeRow row b
$c>> :: forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row b
>>= :: forall a b.
DecodeRow row a -> (a -> DecodeRow row b) -> DecodeRow row b
$c>>= :: forall (row :: RowType) a b.
DecodeRow row a -> (a -> DecodeRow row b) -> DecodeRow row b
Monad
    , forall (row :: RowType). Monad (DecodeRow row)
forall (row :: RowType). Alternative (DecodeRow row)
forall (row :: RowType) a. DecodeRow row a
forall (row :: RowType) a.
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
forall a. DecodeRow row a
forall a. DecodeRow row a -> DecodeRow row a -> DecodeRow row a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. DecodeRow row a -> DecodeRow row a -> DecodeRow row a
$cmplus :: forall (row :: RowType) a.
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
mzero :: forall a. DecodeRow row a
$cmzero :: forall (row :: RowType) a. DecodeRow row a
MonadPlus
    , MonadError Strict.Text )
instance MonadFail (DecodeRow row) where
  fail :: forall a. String -> DecodeRow row a
fail = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- | Run a `DecodeRow`.
runDecodeRow
  :: DecodeRow row y
  -> SOP.NP (SOP.K (Maybe Strict.ByteString)) row
  -> Either Strict.Text y
runDecodeRow :: forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e a. Except e a -> Either e a
runExcept forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (row :: RowType) y.
DecodeRow row y
-> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
unDecodeRow

{- | Append two row decoders with a combining function.

>>> import GHC.Generics as GHC
>>> :{
data L = L {fst :: Int16, snd :: Char}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
data R = R {thrd :: Bool, frth :: Bool}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
type Row = '[
  "fst" ::: 'NotNull 'PGint2,
  "snd" ::: 'NotNull ('PGchar 1),
  "thrd" ::: 'NotNull 'PGbool,
  "frth" ::: 'NotNull 'PGbool]
:}

>>> :{
let
  decode :: DecodeRow Row (L,R)
  decode = appendRows (,) genericRow genericRow
  row4 =
    SOP.K (Just "\NUL\SOH") :*
    SOP.K (Just "a") :*
    SOP.K (Just "\NUL") :*
    SOP.K (Just "\NUL") :* Nil
in runDecodeRow decode row4
:}
Right (L {fst = 1, snd = 'a'},R {thrd = False, frth = False})
-}
appendRows
  :: SOP.SListI left
  => (l -> r -> z) -- ^ combining function
  -> DecodeRow left l -- ^ left decoder
  -> DecodeRow right r -- ^ right decoder
  -> DecodeRow (Join left right) z
appendRows :: forall (left :: RowType) l r z (right :: RowType).
SListI left =>
(l -> r -> z)
-> DecodeRow left l
-> DecodeRow right r
-> DecodeRow (Join left right) z
appendRows l -> r -> z
f DecodeRow left l
decL DecodeRow right r
decR = forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow forall a b. (a -> b) -> a -> b
$ \NP (K (Maybe ByteString)) (Join left right)
row -> case forall {k} (xs :: [k]) (ys :: [k]) (expr :: k -> *).
SListI xs =>
NP expr (Join xs ys) -> (NP expr xs, NP expr ys)
disjoin NP (K (Maybe ByteString)) (Join left right)
row of
  (NP (K (Maybe ByteString)) left
rowL, NP (K (Maybe ByteString)) right
rowR) -> l -> r -> z
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow left l
decL NP (K (Maybe ByteString)) left
rowL forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow right r
decR NP (K (Maybe ByteString)) right
rowR

{- | Cons a column and a row decoder with a combining function.

>>> :{
let
  decode :: DecodeRow
    '["fst" ::: 'NotNull 'PGtext, "snd" ::: 'NotNull 'PGint2, "thrd" ::: 'NotNull ('PGchar 1)]
    (String, (Int16, Char))
  decode = consRow (,) #fst (consRow (,) #snd #thrd)
in runDecodeRow decode (SOP.K (Just "hi") :* SOP.K (Just "\NUL\SOH") :* SOP.K (Just "a") :* Nil)
:}
Right ("hi",(1,'a'))
-}
consRow
  :: FromValue head h
  => (h -> t -> z) -- ^ combining function
  -> Alias col -- ^ alias of head
  -> DecodeRow tail t -- ^ tail decoder
  -> DecodeRow (col ::: head ': tail) z
consRow :: forall (head :: NullType) h t z (col :: Symbol) (tail :: RowType).
FromValue head h =>
(h -> t -> z)
-> Alias col
-> DecodeRow tail t
-> DecodeRow ((col ::: head) : tail) z
consRow h -> t -> z
f Alias col
_ DecodeRow tail t
dec = forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow forall a b. (a -> b) -> a -> b
$ \case
  (SOP.K Maybe ByteString
h :: SOP.K (Maybe Strict.ByteString) (col ::: head)) :* NP (K (Maybe ByteString)) xs
t
    -> h -> t -> z
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
fromValue @head Maybe ByteString
h forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow tail t
dec NP (K (Maybe ByteString)) xs
t

-- | Smart constructor for a `DecodeRow`.
decodeRow
  :: (SOP.NP (SOP.K (Maybe Strict.ByteString)) row -> Either Strict.Text y)
  -> DecodeRow row y
decodeRow :: forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow NP (K (Maybe ByteString)) row -> Either Text y
dec = forall (row :: RowType) y.
ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
DecodeRow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K (Maybe ByteString)) row -> Either Text y
dec
instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty y)
  => IsLabel fld (DecodeRow (fld ::: ty ': row) y) where
    fromLabel :: DecodeRow ((fld ::: ty) : row) y
fromLabel = forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow forall a b. (a -> b) -> a -> b
$ \(SOP.K Maybe ByteString
b SOP.:* NP (K (Maybe ByteString)) xs
_) -> do
      let
        flderr :: Text
flderr = forall a. Monoid a => [a] -> a
mconcat
          [ Text
"field name: "
          , Text
"\"", forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
SOP.Proxy @fld)), Text
"\"; "
          ]
      forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Text
flderr forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
fromValue @ty Maybe ByteString
b
instance {-# OVERLAPPABLE #-} IsLabel fld (DecodeRow row y)
  => IsLabel fld (DecodeRow (field ': row) y) where
    fromLabel :: DecodeRow (field : row) y
fromLabel = forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow forall a b. (a -> b) -> a -> b
$ \(K (Maybe ByteString) x
_ SOP.:* NP (K (Maybe ByteString)) xs
bs) ->
      forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @fld) NP (K (Maybe ByteString)) xs
bs
instance {-# OVERLAPPING #-} (KnownSymbol fld, FromValue ty (Maybe y))
  => IsLabel fld (MaybeT (DecodeRow (fld ::: ty ': row)) y) where
    fromLabel :: MaybeT (DecodeRow ((fld ::: ty) : row)) y
fromLabel = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow forall a b. (a -> b) -> a -> b
$ \(SOP.K Maybe ByteString
b SOP.:* NP (K (Maybe ByteString)) xs
_) -> do
      let
        flderr :: Text
flderr = forall a. Monoid a => [a] -> a
mconcat
          [ Text
"field name: "
          , Text
"\"", forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
SOP.Proxy @fld)), Text
"\"; "
          ]
      forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Text
flderr forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
fromValue @ty Maybe ByteString
b
instance {-# OVERLAPPABLE #-} IsLabel fld (MaybeT (DecodeRow row) y)
  => IsLabel fld (MaybeT (DecodeRow (field ': row)) y) where
    fromLabel :: MaybeT (DecodeRow (field : row)) y
fromLabel = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow forall a b. (a -> b) -> a -> b
$ \(K (Maybe ByteString) x
_ SOP.:* NP (K (Maybe ByteString)) xs
bs) ->
      forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @fld)) NP (K (Maybe ByteString)) xs
bs

-- | A `GenericRow` constraint to ensure that a Haskell type
-- is a record type,
-- has a `RowPG`,
-- and all its fields and can be decoded from corresponding Postgres fields.
class
  ( SOP.IsRecord y ys
  , row ~ RowPG y
  , SOP.AllZip FromField row ys
  ) => GenericRow row y ys where
  {- | Row decoder for `SOP.Generic` records.

  >>> import qualified GHC.Generics as GHC
  >>> import qualified Generics.SOP as SOP
  >>> data Two = Two {frst :: Int16, scnd :: String} deriving (Show, GHC.Generic, SOP.Generic, SOP.HasDatatypeInfo)
  >>> :{
  let
    decode :: DecodeRow '[ "frst" ::: 'NotNull 'PGint2, "scnd" ::: 'NotNull 'PGtext] Two
    decode = genericRow
  in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil)
  :}
  Right (Two {frst = 2, scnd = "two"})
  -}
  genericRow :: DecodeRow row y
instance
  ( row ~ RowPG y
  , SOP.IsRecord y ys
  , SOP.AllZip FromField row ys
  ) => GenericRow row y ys where
  genericRow :: DecodeRow row y
genericRow
    = forall (row :: RowType) y.
ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
DecodeRow
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT
    forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (r :: RecordCode). IsRecord a r => RecordRep a -> a
SOP.fromRecord
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
SOP.hsequence'
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k1 l1 k2 l2 (h1 :: (k1 -> *) -> l1 -> *)
       (h2 :: (k2 -> *) -> l2 -> *) (c :: k1 -> k2 -> Constraint)
       (xs :: l1) (ys :: l2) (proxy :: (k1 -> k2 -> Constraint) -> *)
       (f :: k1 -> *) (g :: k2 -> *).
(HTrans h1 h2, AllZipN (Prod h1) c xs ys) =>
proxy c
-> (forall (x :: k1) (y :: k2). c x y => f x -> g y)
-> h1 f xs
-> h2 g ys
SOP.htrans (forall {k} (t :: k). Proxy t
SOP.Proxy @FromField) forall (ty :: (Symbol, NullType)) (z :: (Symbol, *)).
FromField ty z =>
K (Maybe ByteString) ty -> (:.:) (Except Text) P z
runField
    where
      runField
        :: forall ty z. FromField ty z
        => SOP.K (Maybe Strict.ByteString) ty
        -> (Except Strict.Text SOP.:.: SOP.P) z
      runField :: forall (ty :: (Symbol, NullType)) (z :: (Symbol, *)).
FromField ty z =>
K (Maybe ByteString) ty -> (:.:) (Except Text) P z
runField
        = forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: (Symbol, NullType)) (y :: (Symbol, *)).
FromField field y =>
Maybe ByteString -> Either Text (P y)
fromField @ty
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). K a b -> a
SOP.unK

{- | Assistant class for `genericProductRow`,
this class forgets the name of a field while decoding it.
-}
class FromAliasedValue (field :: (Symbol, NullType)) (y :: Type) where
  fromAliasedValue :: Maybe Strict.ByteString -> Either Strict.Text y
instance FromValue ty y => FromAliasedValue (fld ::: ty) y where
  fromAliasedValue :: Maybe ByteString -> Either Text y
fromAliasedValue = forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
fromValue @ty

{- | Positionally `DecodeRow`. More general than `genericRow`,
which matches records both positionally and by field name,
`genericProductRow` matches records _or_ tuples purely positionally.

>>> import qualified GHC.Generics as GHC
>>> import qualified Generics.SOP as SOP
>>> :{
let
  decode :: DecodeRow '[ "foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGtext] (Int16, String)
  decode = genericProductRow
in runDecodeRow decode (SOP.K (Just "\NUL\STX") :* SOP.K (Just "two") :* Nil)
:}
Right (2,"two")
-}
genericProductRow
  :: ( SOP.IsProductType y ys
     , SOP.AllZip FromAliasedValue row ys
     )
  => DecodeRow row y
genericProductRow :: forall y (ys :: [*]) (row :: RowType).
(IsProductType y ys, AllZip FromAliasedValue row ys) =>
DecodeRow row y
genericProductRow
  = forall (row :: RowType) y.
ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
DecodeRow
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT
  forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (xs :: [*]). IsProductType a xs => NP I xs -> a
SOP.productTypeTo
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
SOP.hsequence'
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k1 l1 k2 l2 (h1 :: (k1 -> *) -> l1 -> *)
       (h2 :: (k2 -> *) -> l2 -> *) (c :: k1 -> k2 -> Constraint)
       (xs :: l1) (ys :: l2) (proxy :: (k1 -> k2 -> Constraint) -> *)
       (f :: k1 -> *) (g :: k2 -> *).
(HTrans h1 h2, AllZipN (Prod h1) c xs ys) =>
proxy c
-> (forall (x :: k1) (y :: k2). c x y => f x -> g y)
-> h1 f xs
-> h2 g ys
SOP.htrans (forall {k} (t :: k). Proxy t
SOP.Proxy @FromAliasedValue) forall (ty :: (Symbol, NullType)) z.
FromAliasedValue ty z =>
K (Maybe ByteString) ty -> (:.:) (Except Text) I z
runField
  where
    runField
      :: forall ty z. FromAliasedValue ty z
      => SOP.K (Maybe Strict.ByteString) ty
      -> (Except Strict.Text SOP.:.: SOP.I) z
    runField :: forall (ty :: (Symbol, NullType)) z.
FromAliasedValue ty z =>
K (Maybe ByteString) ty -> (:.:) (Except Text) I z
runField
      = forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> I a
SOP.I
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (field :: (Symbol, NullType)) y.
FromAliasedValue field y =>
Maybe ByteString -> Either Text y
fromAliasedValue @ty
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). K a b -> a
SOP.unK

{- |
>>> :{
data Dir = North | East | South | West
instance IsPG Dir where
  type PG Dir = 'PGenum '["north", "south", "east", "west"]
instance FromPG Dir where
  fromPG = enumValue $
    label @"north" North :*
    label @"south" South :*
    label @"east" East :*
    label @"west" West
:}
-}
enumValue
  :: (SOP.All KnownSymbol labels, PG y ~ 'PGenum labels)
  => NP (SOP.K y) labels -- ^ labels
  -> StateT Strict.ByteString (Except Strict.Text) y
enumValue :: forall (labels :: [Symbol]) y.
(All KnownSymbol labels, PG y ~ 'PGenum labels) =>
NP (K y) labels -> StateT ByteString (Except Text) y
enumValue = forall x. Value x -> StateT ByteString (Except Text) x
devalue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Text -> Maybe a) -> Value a
enum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (labels :: [Symbol]) y.
All KnownSymbol labels =>
NP (K y) labels -> Text -> Maybe y
labels
  where
  labels
    :: SOP.All KnownSymbol labels
    => NP (SOP.K y) labels
    -> Text -> Maybe y
  labels :: forall (labels :: [Symbol]) y.
All KnownSymbol labels =>
NP (K y) labels -> Text -> Maybe y
labels = \case
    NP (K y) labels
Nil -> \Text
_ -> forall a. Maybe a
Nothing
    ((K y x
y :: SOP.K y label) :* NP (K y) xs
ys) -> \ Text
str ->
      if Text
str forall a. Eq a => a -> a -> Bool
== forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
SOP.Proxy @label))
      then forall a. a -> Maybe a
Just (forall {k} a (b :: k). K a b -> a
SOP.unK K y x
y)
      else forall (labels :: [Symbol]) y.
All KnownSymbol labels =>
NP (K y) labels -> Text -> Maybe y
labels NP (K y) xs
ys Text
str