{-|
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 (..)
  , appendRows
  , consRow
    -- * Decoding Classes
  , FromValue (..)
  , FromField (..)
  , 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 :: Value x -> StateT ByteString (Except Text) x
devalue = Value x -> StateT ByteString (Except Text) x
forall a b. a -> b
unsafeCoerce

revalue :: StateT Strict.ByteString (Except Strict.Text) x -> Value x
revalue :: StateT ByteString (Except Text) x -> Value x
revalue = StateT ByteString (Except Text) x -> Value x
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 :: DecodeRow row y -> StateT ByteString (Except Text) y
rowValue DecodeRow row y
decoder = Value y -> StateT ByteString (Except Text) y
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value y -> StateT ByteString (Except Text) y)
-> Value y -> StateT ByteString (Except Text) y
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 = Value (NP (K (Maybe ByteString)) row)
-> ByteString -> Either Text (NP (K (Maybe ByteString)) row)
forall a. Value a -> ByteString -> Either Text a
valueParser (Value (NP (K (Maybe ByteString)) row)
 -> ByteString -> Either Text (NP (K (Maybe ByteString)) row))
-> Value (NP (K (Maybe ByteString)) row)
-> ByteString
-> Either Text (NP (K (Maybe ByteString)) row)
forall a b. (a -> b) -> a -> b
$ do
      Int -> BinaryParser ()
unitOfSize Int
4
      NP (BinaryParser :.: K (Maybe ByteString)) row
-> Value (NP (K (Maybe ByteString)) row)
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' (NP (BinaryParser :.: K (Maybe ByteString)) row
 -> Value (NP (K (Maybe ByteString)) row))
-> NP (BinaryParser :.: K (Maybe ByteString)) row
-> Value (NP (K (Maybe ByteString)) row)
forall a b. (a -> b) -> a -> b
$ (forall (a :: (Symbol, NullType)).
 (:.:) BinaryParser (K (Maybe ByteString)) a)
-> NP (BinaryParser :.: K (Maybe ByteString)) row
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 :: (Symbol, NullType)).
  (:.:) BinaryParser (K (Maybe ByteString)) a)
 -> NP (BinaryParser :.: K (Maybe ByteString)) row)
-> (forall (a :: (Symbol, NullType)).
    (:.:) BinaryParser (K (Maybe ByteString)) a)
-> NP (BinaryParser :.: K (Maybe ByteString)) row
forall a b. (a -> b) -> a -> b
$ BinaryParser (K (Maybe ByteString) a)
-> (:.:) BinaryParser (K (Maybe ByteString)) a
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp (BinaryParser (K (Maybe ByteString) a)
 -> (:.:) BinaryParser (K (Maybe ByteString)) a)
-> BinaryParser (K (Maybe ByteString) a)
-> (:.:) BinaryParser (K (Maybe ByteString)) a
forall a b. (a -> b) -> a -> b
$ do
        Int -> BinaryParser ()
unitOfSize Int
4
        Int32
len :: Int32 <- Int -> BinaryParser Int32 -> BinaryParser Int32
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 BinaryParser Int32
forall a. (Integral a, Bits a) => Value a
int
        if Int32
len Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== -Int32
1
          then K (Maybe ByteString) a -> BinaryParser (K (Maybe ByteString) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> K (Maybe ByteString) a
forall k a (b :: k). a -> K a b
SOP.K Maybe ByteString
forall a. Maybe a
Nothing)
          else Maybe ByteString -> K (Maybe ByteString) a
forall k a (b :: k). a -> K a b
SOP.K (Maybe ByteString -> K (Maybe ByteString) a)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> K (Maybe ByteString) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> K (Maybe ByteString) a)
-> BinaryParser ByteString -> BinaryParser (K (Maybe ByteString) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> BinaryParser ByteString
bytesOfSize (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  in (ByteString -> Either Text y) -> Value y
forall a. (ByteString -> Either Text a) -> Value a
fn (DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow row y
decoder (NP (K (Maybe ByteString)) row -> Either Text y)
-> (ByteString -> Either Text (NP (K (Maybe ByteString)) row))
-> ByteString
-> Either Text y
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 = Value Bool -> StateT ByteString (Except Text) Bool
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Bool
bool
instance FromPG Int16 where
  fromPG :: StateT ByteString (Except Text) Int16
fromPG = Value Int16 -> StateT ByteString (Except Text) Int16
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Int16
forall a. (Integral a, Bits a) => Value a
int
instance FromPG Int32 where
  fromPG :: StateT ByteString (Except Text) Int32
fromPG = BinaryParser Int32 -> StateT ByteString (Except Text) Int32
forall x. Value x -> StateT ByteString (Except Text) x
devalue BinaryParser Int32
forall a. (Integral a, Bits a) => Value a
int
instance FromPG Int64 where
  fromPG :: StateT ByteString (Except Text) Int64
fromPG = Value Int64 -> StateT ByteString (Except Text) Int64
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Int64
forall a. (Integral a, Bits a) => Value a
int
instance FromPG Oid where
  fromPG :: StateT ByteString (Except Text) Oid
fromPG = Value Oid -> StateT ByteString (Except Text) Oid
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value Oid -> StateT ByteString (Except Text) Oid)
-> Value Oid -> StateT ByteString (Except Text) Oid
forall a b. (a -> b) -> a -> b
$ CUInt -> Oid
Oid (CUInt -> Oid) -> BinaryParser CUInt -> Value Oid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinaryParser CUInt
forall a. (Integral a, Bits a) => Value a
int
instance FromPG Float where
  fromPG :: StateT ByteString (Except Text) Float
fromPG = Value Float -> StateT ByteString (Except Text) Float
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Float
float4
instance FromPG Double where
  fromPG :: StateT ByteString (Except Text) Double
fromPG = Value Double -> StateT ByteString (Except Text) Double
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Double
float8
instance FromPG Scientific where
  fromPG :: StateT ByteString (Except Text) Scientific
fromPG = Value Scientific -> StateT ByteString (Except Text) Scientific
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Scientific
numeric
instance FromPG Money where
  fromPG :: StateT ByteString (Except Text) Money
fromPG = Value Money -> StateT ByteString (Except Text) Money
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value Money -> StateT ByteString (Except Text) Money)
-> Value Money -> StateT ByteString (Except Text) Money
forall a b. (a -> b) -> a -> b
$  Int64 -> Money
Money (Int64 -> Money) -> Value Int64 -> Value Money
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value Int64
forall a. (Integral a, Bits a) => Value a
int
instance FromPG UUID where
  fromPG :: StateT ByteString (Except Text) UUID
fromPG = Value UUID -> StateT ByteString (Except Text) UUID
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 = Value (NetAddr IP) -> StateT ByteString (Except Text) (NetAddr IP)
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 = Value Char -> StateT ByteString (Except Text) Char
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 = Value Text -> StateT ByteString (Except Text) Text
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 = Value Text -> StateT ByteString (Except Text) Text
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 = Value String -> StateT ByteString (Except Text) String
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value String -> StateT ByteString (Except Text) String)
-> Value String -> StateT ByteString (Except Text) String
forall a b. (a -> b) -> a -> b
$ Text -> String
Strict.Text.unpack (Text -> String) -> Value Text -> Value String
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 = BinaryParser ByteString
-> StateT ByteString (Except Text) ByteString
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 = Value ByteString -> StateT ByteString (Except Text) ByteString
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 = Value (VarChar n) -> StateT ByteString (Except Text) (VarChar n)
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (VarChar n) -> StateT ByteString (Except Text) (VarChar n))
-> Value (VarChar n) -> StateT ByteString (Except Text) (VarChar n)
forall a b. (a -> b) -> a -> b
$ Value Text
text_strict Value Text -> (Text -> Value (VarChar n)) -> Value (VarChar n)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t ->
    case Text -> Maybe (VarChar n)
forall (n :: Nat). KnownNat n => Text -> Maybe (VarChar n)
varChar Text
t of
      Maybe (VarChar n)
Nothing -> Text -> Value (VarChar n)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Value (VarChar n)) -> Text -> Value (VarChar n)
forall a b. (a -> b) -> a -> b
$ String -> Text
Strict.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Source for VarChar has wrong length"
        , String
"; expected length "
        , Integer -> String
forall a. Show a => a -> String
show (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
SOP.Proxy @n))
        , String
", actual length "
        , Int -> String
forall a. Show a => a -> String
show (Text -> Int
Strict.Text.length Text
t)
        , String
"."
        ]
      Just VarChar n
x -> VarChar n -> Value (VarChar n)
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 = Value (FixChar n) -> StateT ByteString (Except Text) (FixChar n)
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (FixChar n) -> StateT ByteString (Except Text) (FixChar n))
-> Value (FixChar n) -> StateT ByteString (Except Text) (FixChar n)
forall a b. (a -> b) -> a -> b
$ Value Text
text_strict Value Text -> (Text -> Value (FixChar n)) -> Value (FixChar n)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t ->
    case Text -> Maybe (FixChar n)
forall (n :: Nat). KnownNat n => Text -> Maybe (FixChar n)
fixChar Text
t of
      Maybe (FixChar n)
Nothing -> Text -> Value (FixChar n)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> Value (FixChar n)) -> Text -> Value (FixChar n)
forall a b. (a -> b) -> a -> b
$ String -> Text
Strict.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Source for FixChar has wrong length"
        , String
"; expected length "
        , Integer -> String
forall a. Show a => a -> String
show (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
SOP.Proxy @n))
        , String
", actual length "
        , Int -> String
forall a. Show a => a -> String
show (Text -> Int
Strict.Text.length Text
t)
        , String
"."
        ]
      Just FixChar n
x -> FixChar n -> Value (FixChar n)
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 = StateT ByteString (Except Text) x
-> StateT ByteString (Except Text) (Const x tag)
coerce (StateT ByteString (Except Text) x
 -> StateT ByteString (Except Text) (Const x tag))
-> StateT ByteString (Except Text) x
-> StateT ByteString (Except Text) (Const x tag)
forall a b. (a -> b) -> a -> b
$ FromPG x => StateT ByteString (Except Text) x
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 = StateT ByteString (Except Text) x
-> StateT ByteString (Except Text) (K x tag)
coerce (StateT ByteString (Except Text) x
 -> StateT ByteString (Except Text) (K x tag))
-> StateT ByteString (Except Text) x
-> StateT ByteString (Except Text) (K x tag)
forall a b. (a -> b) -> a -> b
$ FromPG x => StateT ByteString (Except Text) x
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 = StateT ByteString (Except Text) x
-> StateT ByteString (Except Text) (Constant x tag)
coerce (StateT ByteString (Except Text) x
 -> StateT ByteString (Except Text) (Constant x tag))
-> StateT ByteString (Except Text) x
-> StateT ByteString (Except Text) (Constant x tag)
forall a b. (a -> b) -> a -> b
$ FromPG x => StateT ByteString (Except Text) x
forall y. FromPG y => StateT ByteString (Except Text) y
fromPG @x
instance FromPG Day where
  fromPG :: StateT ByteString (Except Text) Day
fromPG = Value Day -> StateT ByteString (Except Text) Day
forall x. Value x -> StateT ByteString (Except Text) x
devalue Value Day
date
instance FromPG TimeOfDay where
  fromPG :: StateT ByteString (Except Text) TimeOfDay
fromPG = Value TimeOfDay -> StateT ByteString (Except Text) TimeOfDay
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 = Value (TimeOfDay, TimeZone)
-> StateT ByteString (Except Text) (TimeOfDay, TimeZone)
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 = Value LocalTime -> StateT ByteString (Except Text) LocalTime
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 = Value UTCTime -> StateT ByteString (Except Text) UTCTime
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 = Value DiffTime -> StateT ByteString (Except Text) DiffTime
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 = Value Value -> StateT ByteString (Except Text) Value
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 = Value (Json x) -> StateT ByteString (Except Text) (Json x)
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (Json x) -> StateT ByteString (Except Text) (Json x))
-> Value (Json x) -> StateT ByteString (Except Text) (Json x)
forall a b. (a -> b) -> a -> b
$ x -> Json x
forall hask. hask -> Json hask
Json (x -> Json x) -> BinaryParser x -> Value (Json x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (ByteString -> Either Text x) -> BinaryParser x
forall a. (ByteString -> Either Text a) -> Value a
json_bytes ((String -> Text) -> Either String x -> Either Text x
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left String -> Text
Strict.Text.pack (Either String x -> Either Text x)
-> (ByteString -> Either String x) -> ByteString -> Either Text x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String x
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 = Value (Jsonb x) -> StateT ByteString (Except Text) (Jsonb x)
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (Jsonb x) -> StateT ByteString (Except Text) (Jsonb x))
-> Value (Jsonb x) -> StateT ByteString (Except Text) (Jsonb x)
forall a b. (a -> b) -> a -> b
$ x -> Jsonb x
forall hask. hask -> Jsonb hask
Jsonb (x -> Jsonb x) -> BinaryParser x -> Value (Jsonb x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (ByteString -> Either Text x) -> BinaryParser x
forall a. (ByteString -> Either Text a) -> Value a
jsonb_bytes ((String -> Text) -> Either String x -> Either Text x
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left String -> Text
Strict.Text.pack (Either String x -> Either Text x)
-> (ByteString -> Either String x) -> ByteString -> Either Text x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String x
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 = Vector a -> VarArray (Vector a)
forall arr. arr -> VarArray arr
VarArray (Vector a -> VarArray (Vector a))
-> f (Vector a) -> f (VarArray (Vector a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> f a -> f (Vector a)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
n f a
x
      in
        Value (VarArray (Vector y))
-> StateT ByteString (Except Text) (VarArray (Vector y))
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (VarArray (Vector y))
 -> StateT ByteString (Except Text) (VarArray (Vector y)))
-> (Array (VarArray (Vector y)) -> Value (VarArray (Vector y)))
-> Array (VarArray (Vector y))
-> StateT ByteString (Except Text) (VarArray (Vector y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array (VarArray (Vector y)) -> Value (VarArray (Vector y))
forall a. Array a -> Value a
array (Array (VarArray (Vector y))
 -> StateT ByteString (Except Text) (VarArray (Vector y)))
-> Array (VarArray (Vector y))
-> StateT ByteString (Except Text) (VarArray (Vector y))
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
 Monad m =>
 Int -> m y -> m (VarArray (Vector y)))
-> Array y -> Array (VarArray (Vector y))
forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall (m :: * -> *).
Monad m =>
Int -> m y -> m (VarArray (Vector y))
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
forall y. FromArray '[] (NullPG y) 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 = [a] -> VarArray [a]
forall arr. arr -> VarArray arr
VarArray ([a] -> VarArray [a]) -> f [a] -> f (VarArray [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> f a -> f [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n f a
x
      in
        Value (VarArray [y])
-> StateT ByteString (Except Text) (VarArray [y])
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (VarArray [y])
 -> StateT ByteString (Except Text) (VarArray [y]))
-> (Array (VarArray [y]) -> Value (VarArray [y]))
-> Array (VarArray [y])
-> StateT ByteString (Except Text) (VarArray [y])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array (VarArray [y]) -> Value (VarArray [y])
forall a. Array a -> Value a
array (Array (VarArray [y])
 -> StateT ByteString (Except Text) (VarArray [y]))
-> Array (VarArray [y])
-> StateT ByteString (Except Text) (VarArray [y])
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *). Monad m => Int -> m y -> m (VarArray [y]))
-> Array y -> Array (VarArray [y])
forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall (m :: * -> *). Monad m => Int -> m y -> m (VarArray [y])
forall (f :: * -> *) a.
Applicative f =>
Int -> f a -> f (VarArray [a])
rep
          (forall (dims :: [Nat]) (ty :: NullType) y.
FromArray dims ty y =>
Array y
forall y. FromArray '[] (NullPG y) y => Array y
fromArray @'[] @(NullPG y))
instance FromArray dims ty y => FromPG (FixArray y) where
  fromPG :: StateT ByteString (Except Text) (FixArray y)
fromPG = Value (FixArray y) -> StateT ByteString (Except Text) (FixArray y)
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (FixArray y)
 -> StateT ByteString (Except Text) (FixArray y))
-> Value (FixArray y)
-> StateT ByteString (Except Text) (FixArray y)
forall a b. (a -> b) -> a -> b
$ y -> FixArray y
forall arr. arr -> FixArray arr
FixArray (y -> FixArray y) -> BinaryParser y -> Value (FixArray y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array y -> BinaryParser y
forall a. Array a -> Value a
array (FromArray dims ty y => Array y
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 :: NP ConstructorInfo xss -> String -> Maybe (SOP I xss)
greadConstructor NP ConstructorInfo xss
Nil String
_ = Maybe (SOP I xss)
forall a. Maybe a
Nothing
        greadConstructor (ConstructorInfo x
constructor :* NP ConstructorInfo xs
constructors) String
name =
          if String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorInfo x -> String
forall (xs :: [*]). ConstructorInfo xs -> String
SOP.constructorName ConstructorInfo x
constructor
            then SOP I ('[] : xs) -> Maybe (SOP I ('[] : xs))
forall a. a -> Maybe a
Just (NS (NP I) ('[] : xs) -> SOP I ('[] : xs)
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP (NP I '[] -> NS (NP I) ('[] : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
SOP.Z NP I '[]
forall k (a :: k -> *). NP a '[]
Nil))
            else NS (NP I) ('[] : xs) -> SOP I ('[] : xs)
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP (NS (NP I) ('[] : xs) -> SOP I ('[] : xs))
-> (SOP I xs -> NS (NP I) ('[] : xs))
-> SOP I xs
-> SOP I ('[] : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (NP I) xs -> NS (NP I) ('[] : xs)
forall k (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
SOP.S (NS (NP I) xs -> NS (NP I) ('[] : xs))
-> (SOP I xs -> NS (NP I) xs) -> SOP I xs -> NS (NP I) ('[] : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SOP I xs -> NS (NP I) xs
forall k (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
SOP.unSOP (SOP I xs -> SOP I ('[] : xs))
-> Maybe (SOP I xs) -> Maybe (SOP I ('[] : xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              NP ConstructorInfo xs -> String -> Maybe (SOP I xs)
forall (xss :: [[*]]).
All ((~) '[]) xss =>
NP ConstructorInfo xss -> String -> Maybe (SOP I xss)
greadConstructor NP ConstructorInfo xs
constructors String
name
      in
        Value (Enumerated y)
-> StateT ByteString (Except Text) (Enumerated y)
forall x. Value x -> StateT ByteString (Except Text) x
devalue
        (Value (Enumerated y)
 -> StateT ByteString (Except Text) (Enumerated y))
-> Value (Enumerated y)
-> StateT ByteString (Except Text) (Enumerated y)
forall a b. (a -> b) -> a -> b
$ (y -> Enumerated y) -> BinaryParser y -> Value (Enumerated y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap y -> Enumerated y
forall enum. enum -> Enumerated enum
Enumerated
        (BinaryParser y -> Value (Enumerated y))
-> ((Text -> Maybe y) -> BinaryParser y)
-> (Text -> Maybe y)
-> Value (Enumerated y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe y) -> BinaryParser y
forall a. (Text -> Maybe a) -> Value a
enum
        ((Text -> Maybe y) -> Value (Enumerated y))
-> (Text -> Maybe y) -> Value (Enumerated y)
forall a b. (a -> b) -> a -> b
$ (SOP I (Code y) -> y) -> Maybe (SOP I (Code y)) -> Maybe y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SOP I (Code y) -> y
forall a. Generic a => Rep a -> a
SOP.to
        (Maybe (SOP I (Code y)) -> Maybe y)
-> (Text -> Maybe (SOP I (Code y))) -> Text -> Maybe y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP ConstructorInfo (Code y) -> String -> Maybe (SOP I (Code y))
forall (xss :: [[*]]).
All ((~) '[]) xss =>
NP ConstructorInfo xss -> String -> Maybe (SOP I xss)
greadConstructor
          (DatatypeInfo (Code y) -> NP ConstructorInfo (Code y)
forall (xss :: [[*]]). DatatypeInfo xss -> NP ConstructorInfo xss
SOP.constructorInfo (Proxy y -> DatatypeInfo (Code y)
forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
SOP.datatypeInfo (Proxy y
forall k (t :: k). Proxy t
SOP.Proxy @y)))
        (String -> Maybe (SOP I (Code y)))
-> (Text -> String) -> Text -> Maybe (SOP I (Code 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 = DecodeRow row (Composite y)
-> StateT ByteString (Except Text) (Composite y)
forall y (row :: RowType).
(PG y ~ 'PGcomposite row, SListI row) =>
DecodeRow row y -> StateT ByteString (Except Text) y
rowValue (y -> Composite y
forall record. record -> Composite record
Composite (y -> Composite y)
-> DecodeRow row y -> DecodeRow row (Composite y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeRow row y
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 = Value (Range y) -> StateT ByteString (Except Text) (Range y)
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value (Range y) -> StateT ByteString (Except Text) (Range y))
-> Value (Range y) -> StateT ByteString (Except Text) (Range y)
forall a b. (a -> b) -> a -> b
$ do
    Word8
flag <- BinaryParser Word8
byte
    if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
0 then Range y -> Value (Range y)
forall (m :: * -> *) a. Monad m => a -> m a
return Range y
forall x. Range x
Empty else do
      Bound y
lower <-
        if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
3
          then Bound y -> BinaryParser (Bound y)
forall (m :: * -> *) a. Monad m => a -> m a
return Bound y
forall x. Bound x
Infinite
          else do
            Int
len <- Int -> BinaryParser Int -> BinaryParser Int
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 BinaryParser Int
forall a. (Integral a, Bits a) => Value a
int
            y
l <- Int -> BinaryParser y -> BinaryParser y
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
len (StateT ByteString (Except Text) y -> BinaryParser y
forall x. StateT ByteString (Except Text) x -> Value x
revalue StateT ByteString (Except Text) y
forall y. FromPG y => StateT ByteString (Except Text) y
fromPG)
            Bound y -> BinaryParser (Bound y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bound y -> BinaryParser (Bound y))
-> Bound y -> BinaryParser (Bound y)
forall a b. (a -> b) -> a -> b
$ if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
1 then y -> Bound y
forall x. x -> Bound x
Closed y
l else y -> Bound y
forall x. x -> Bound x
Open y
l
      Bound y
upper <-
        if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
4
          then Bound y -> BinaryParser (Bound y)
forall (m :: * -> *) a. Monad m => a -> m a
return Bound y
forall x. Bound x
Infinite
          else do
            Int
len <- Int -> BinaryParser Int -> BinaryParser Int
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
4 BinaryParser Int
forall a. (Integral a, Bits a) => Value a
int
            y
l <- Int -> BinaryParser y -> BinaryParser y
forall a. Int -> BinaryParser a -> BinaryParser a
sized Int
len (StateT ByteString (Except Text) y -> BinaryParser y
forall x. StateT ByteString (Except Text) x -> Value x
revalue StateT ByteString (Except Text) y
forall y. FromPG y => StateT ByteString (Except Text) y
fromPG)
            Bound y -> BinaryParser (Bound y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bound y -> BinaryParser (Bound y))
-> Bound y -> BinaryParser (Bound y)
forall a b. (a -> b) -> a -> b
$ if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
flag Int
2 then y -> Bound y
forall x. x -> Bound x
Closed y
l else y -> Bound y
forall x. x -> Bound x
Open y
l
      Range y -> Value (Range y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Range y -> Value (Range y)) -> Range y -> Value (Range y)
forall a b. (a -> b) -> a -> b
$ Bound y -> Bound y -> Range y
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 -> Text -> Either Text y
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"fromField: saw NULL when expecting NOT NULL"
    Just ByteString
bytestring -> Value y -> ByteString -> Either Text y
forall a. Value a -> ByteString -> Either Text a
valueParser (StateT ByteString (Except Text) y -> Value y
forall x. StateT ByteString (Except Text) x -> Value x
revalue StateT ByteString (Except Text) y
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 -> Maybe y -> Either Text (Maybe y)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe y
forall a. Maybe a
Nothing
    Just ByteString
bytestring -> (y -> Maybe y) -> Either Text y -> Either Text (Maybe y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap y -> Maybe y
forall a. a -> Maybe a
Just (Either Text y -> Either Text (Maybe y))
-> Either Text y -> Either Text (Maybe y)
forall a b. (a -> b) -> a -> b
$ Value y -> ByteString -> Either Text y
forall a. Value a -> ByteString -> Either Text a
valueParser (StateT ByteString (Except Text) y -> Value y
forall x. StateT ByteString (Except Text) x -> Value x
revalue StateT ByteString (Except Text) y
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 = (y -> P (fld1 ::: y))
-> Either Text y -> Either Text (P (fld1 ::: y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap y -> P (fld1 ::: y)
forall a (p :: (a, *)). Snd p -> P p
SOP.P (Either Text y -> Either Text (P (fld1 ::: y)))
-> (Maybe ByteString -> Either Text y)
-> Maybe ByteString
-> Either Text (P (fld1 ::: y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall y. FromValue ty y => Maybe ByteString -> Either Text y
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 = Value y -> Array y
forall a. Value a -> Array a
valueArray (StateT ByteString (Except Text) y -> Value y
forall x. StateT ByteString (Except Text) x -> Value x
revalue StateT ByteString (Except Text) y
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 = Value y -> Array (Maybe y)
forall a. Value a -> Array (Maybe a)
nullableValueArray (StateT ByteString (Except Text) y -> Value y
forall x. StateT ByteString (Except Text) x -> Value x
revalue StateT ByteString (Except Text) y
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
_ = (NP I x -> b) -> f (NP I x) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SOP I (x : xs) -> b
forall a. Generic a => Rep a -> a
SOP.to (SOP I (x : xs) -> b) -> (NP I x -> SOP I (x : xs)) -> NP I x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (NP I) (x : xs) -> SOP I (x : xs)
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP.SOP (NS (NP I) (x : xs) -> SOP I (x : xs))
-> (NP I x -> NS (NP I) (x : xs)) -> NP I x -> SOP I (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I x -> NS (NP I) (x : xs)
forall k (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
SOP.Z) (f (NP I x) -> f b) -> (f x -> f (NP I x)) -> f x -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> f (NP I x)
forall x (xs :: [*]) (m :: * -> *).
(All ((~) x) xs, Monad m, SListI xs) =>
m x -> m (NP I xs)
replicateMN
      in
        (forall (m :: * -> *). Monad m => Int -> m y -> m product)
-> Array y -> Array product
forall a b.
(forall (m :: * -> *). Monad m => Int -> m a -> m b)
-> Array a -> Array b
dimensionArray forall (m :: * -> *). Monad m => Int -> m y -> m product
forall (f :: * -> *) b x (x :: [*]) (xs :: [[*]]) p.
(Generic b, Monad f, All ((~) x) x, Code b ~ (x : xs)) =>
p -> f x -> f b
rep (FromArray dims ty y => Array y
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 :: m x -> m (NP I xs)
replicateMN m x
mx = NP (m :.: I) xs -> m (NP I xs)
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' (NP (m :.: I) xs -> m (NP I xs)) -> NP (m :.: I) xs -> m (NP I xs)
forall a b. (a -> b) -> a -> b
$
  Proxy ((~) x)
-> (forall a. (x ~ a) => (:.:) m I a) -> NP (m :.: I) xs
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 (Proxy ((~) x)
forall k (t :: k). Proxy t
SOP.Proxy :: SOP.Proxy ((~) x)) (m (I x) -> (:.:) m I x
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp (x -> I x
forall a. a -> I a
SOP.I (x -> I x) -> m x -> m (I x)
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
  { 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
    ( a -> DecodeRow row b -> DecodeRow row a
(a -> b) -> DecodeRow row a -> DecodeRow row b
(forall a b. (a -> b) -> DecodeRow row a -> DecodeRow row b)
-> (forall a b. a -> DecodeRow row b -> DecodeRow row a)
-> Functor (DecodeRow row)
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
<$ :: a -> DecodeRow row b -> DecodeRow row a
$c<$ :: forall (row :: RowType) a b.
a -> DecodeRow row b -> DecodeRow row a
fmap :: (a -> b) -> DecodeRow row a -> DecodeRow row b
$cfmap :: forall (row :: RowType) a b.
(a -> b) -> DecodeRow row a -> DecodeRow row b
Functor
    , Functor (DecodeRow row)
a -> DecodeRow row a
Functor (DecodeRow row)
-> (forall a. a -> DecodeRow row a)
-> (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 a b.
    DecodeRow row a -> DecodeRow row b -> DecodeRow row b)
-> (forall a b.
    DecodeRow row a -> DecodeRow row b -> DecodeRow row a)
-> Applicative (DecodeRow row)
DecodeRow row a -> DecodeRow row b -> DecodeRow row b
DecodeRow row a -> DecodeRow row b -> DecodeRow row a
DecodeRow row (a -> b) -> DecodeRow row a -> DecodeRow row b
(a -> b -> c)
-> DecodeRow row a -> DecodeRow row b -> DecodeRow row c
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
<* :: DecodeRow row a -> DecodeRow row b -> DecodeRow row a
$c<* :: forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row a
*> :: 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 :: (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
<*> :: 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 :: a -> DecodeRow row a
$cpure :: forall (row :: RowType) a. a -> DecodeRow row a
$cp1Applicative :: forall (row :: RowType). Functor (DecodeRow row)
Applicative
    , Applicative (DecodeRow row)
DecodeRow row a
Applicative (DecodeRow row)
-> (forall a. DecodeRow row a)
-> (forall a.
    DecodeRow row a -> DecodeRow row a -> DecodeRow row a)
-> (forall a. DecodeRow row a -> DecodeRow row [a])
-> (forall a. DecodeRow row a -> DecodeRow row [a])
-> Alternative (DecodeRow row)
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
DecodeRow row a -> DecodeRow row [a]
DecodeRow row a -> DecodeRow row [a]
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 :: DecodeRow row a -> DecodeRow row [a]
$cmany :: forall (row :: RowType) a. DecodeRow row a -> DecodeRow row [a]
some :: DecodeRow row a -> DecodeRow row [a]
$csome :: forall (row :: RowType) a. DecodeRow row a -> DecodeRow row [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 :: DecodeRow row a
$cempty :: forall (row :: RowType) a. DecodeRow row a
$cp1Alternative :: forall (row :: RowType). Applicative (DecodeRow row)
Alternative
    , Applicative (DecodeRow row)
a -> DecodeRow row a
Applicative (DecodeRow row)
-> (forall a b.
    DecodeRow row a -> (a -> DecodeRow row b) -> DecodeRow row b)
-> (forall a b.
    DecodeRow row a -> DecodeRow row b -> DecodeRow row b)
-> (forall a. a -> DecodeRow row a)
-> Monad (DecodeRow row)
DecodeRow row a -> (a -> DecodeRow row b) -> DecodeRow row b
DecodeRow row a -> DecodeRow row b -> DecodeRow row b
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 :: a -> DecodeRow row a
$creturn :: forall (row :: RowType) a. a -> DecodeRow row a
>> :: DecodeRow row a -> DecodeRow row b -> DecodeRow row b
$c>> :: forall (row :: RowType) a b.
DecodeRow row a -> DecodeRow row b -> DecodeRow row 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
$cp1Monad :: forall (row :: RowType). Applicative (DecodeRow row)
Monad
    , Monad (DecodeRow row)
Alternative (DecodeRow row)
DecodeRow row a
Alternative (DecodeRow row)
-> Monad (DecodeRow row)
-> (forall a. DecodeRow row a)
-> (forall a.
    DecodeRow row a -> DecodeRow row a -> DecodeRow row a)
-> MonadPlus (DecodeRow row)
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
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 :: DecodeRow row a -> DecodeRow row a -> DecodeRow row a
$cmplus :: forall (row :: RowType) a.
DecodeRow row a -> DecodeRow row a -> DecodeRow row a
mzero :: DecodeRow row a
$cmzero :: forall (row :: RowType) a. DecodeRow row a
$cp2MonadPlus :: forall (row :: RowType). Monad (DecodeRow row)
$cp1MonadPlus :: forall (row :: RowType). Alternative (DecodeRow row)
MonadPlus
    , MonadError Strict.Text )
instance MonadFail (DecodeRow row) where
  fail :: String -> DecodeRow row a
fail = Text -> DecodeRow row a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> DecodeRow row a)
-> (String -> Text) -> String -> DecodeRow row a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
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 :: DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow = (Except Text y -> Either Text y)
-> (NP (K (Maybe ByteString)) row -> Except Text y)
-> NP (K (Maybe ByteString)) row
-> Either Text y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Except Text y -> Either Text y
forall e a. Except e a -> Either e a
runExcept ((NP (K (Maybe ByteString)) row -> Except Text y)
 -> NP (K (Maybe ByteString)) row -> Either Text y)
-> (DecodeRow row y
    -> NP (K (Maybe ByteString)) row -> Except Text y)
-> DecodeRow row y
-> NP (K (Maybe ByteString)) row
-> Either Text y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> NP (K (Maybe ByteString)) row -> Except Text y
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
 -> NP (K (Maybe ByteString)) row -> Except Text y)
-> (DecodeRow row y
    -> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y)
-> DecodeRow row y
-> NP (K (Maybe ByteString)) row
-> Except Text y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeRow row y
-> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
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 :: (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 = (NP (K (Maybe ByteString)) (Join left right) -> Either Text z)
-> DecodeRow (Join left right) z
forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow ((NP (K (Maybe ByteString)) (Join left right) -> Either Text z)
 -> DecodeRow (Join left right) z)
-> (NP (K (Maybe ByteString)) (Join left right) -> Either Text z)
-> DecodeRow (Join left right) z
forall a b. (a -> b) -> a -> b
$ \NP (K (Maybe ByteString)) (Join left right)
row -> case NP (K (Maybe ByteString)) (Join left right)
-> (NP (K (Maybe ByteString)) left,
    NP (K (Maybe ByteString)) right)
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 (l -> r -> z) -> Either Text l -> Either Text (r -> z)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeRow left l -> NP (K (Maybe ByteString)) left -> Either Text l
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 Either Text (r -> z) -> Either Text r -> Either Text z
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DecodeRow right r
-> NP (K (Maybe ByteString)) right -> Either Text r
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 :: (h -> t -> z)
-> Alias col
-> DecodeRow tail t
-> DecodeRow ((col ::: head) : tail) z
consRow h -> t -> z
f Alias col
_ DecodeRow tail t
dec = (NP (K (Maybe ByteString)) ((col ::: head) : tail)
 -> Either Text z)
-> DecodeRow ((col ::: head) : tail) z
forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow ((NP (K (Maybe ByteString)) ((col ::: head) : tail)
  -> Either Text z)
 -> DecodeRow ((col ::: head) : tail) z)
-> (NP (K (Maybe ByteString)) ((col ::: head) : tail)
    -> Either Text z)
-> DecodeRow ((col ::: head) : tail) z
forall a b. (a -> b) -> a -> b
$ \case
  (SOP.K h :: SOP.K (Maybe Strict.ByteString) (col ::: head)) :* NP (K (Maybe ByteString)) xs
t
    -> h -> t -> z
f (h -> t -> z) -> Either Text h -> Either Text (t -> z)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString -> Either Text h
forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
fromValue @head Maybe ByteString
h Either Text (t -> z) -> Either Text t -> Either Text z
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DecodeRow tail t -> NP (K (Maybe ByteString)) tail -> Either Text t
forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow DecodeRow tail t
dec NP (K (Maybe ByteString)) tail
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 :: (NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow NP (K (Maybe ByteString)) row -> Either Text y
dec = ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
forall (row :: RowType) y.
ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
DecodeRow (ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
 -> DecodeRow row y)
-> ((NP (K (Maybe ByteString)) row -> Except Text y)
    -> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y)
-> (NP (K (Maybe ByteString)) row -> Except Text y)
-> DecodeRow row y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP (K (Maybe ByteString)) row -> Except Text y)
-> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((NP (K (Maybe ByteString)) row -> Except Text y)
 -> DecodeRow row y)
-> (NP (K (Maybe ByteString)) row -> Except Text y)
-> DecodeRow row y
forall a b. (a -> b) -> a -> b
$ Either Text y -> Except Text y
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text y -> Except Text y)
-> (NP (K (Maybe ByteString)) row -> Either Text y)
-> NP (K (Maybe ByteString)) row
-> Except Text y
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 = (NP (K (Maybe ByteString)) ((fld ::: ty) : row) -> Either Text y)
-> DecodeRow ((fld ::: ty) : row) y
forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow ((NP (K (Maybe ByteString)) ((fld ::: ty) : row) -> Either Text y)
 -> DecodeRow ((fld ::: ty) : row) y)
-> (NP (K (Maybe ByteString)) ((fld ::: ty) : row)
    -> Either Text y)
-> DecodeRow ((fld ::: ty) : row) y
forall a b. (a -> b) -> a -> b
$ \(SOP.K Maybe ByteString
b SOP.:* NP (K (Maybe ByteString)) xs
_) -> do
      let
        flderr :: Text
flderr = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"field name: "
          , Text
"\"", String -> Text
forall a. IsString a => String -> a
fromString (Proxy fld -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy fld
forall k (t :: k). Proxy t
SOP.Proxy @fld)), Text
"\"; "
          ]
      (Text -> Text) -> Either Text y -> Either Text y
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Text
flderr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Either Text y -> Either Text y) -> Either Text y -> Either Text y
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Either Text y
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 = (NP (K (Maybe ByteString)) (field : row) -> Either Text y)
-> DecodeRow (field : row) y
forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow ((NP (K (Maybe ByteString)) (field : row) -> Either Text y)
 -> DecodeRow (field : row) y)
-> (NP (K (Maybe ByteString)) (field : row) -> Either Text y)
-> DecodeRow (field : row) y
forall a b. (a -> b) -> a -> b
$ \(K (Maybe ByteString) x
_ SOP.:* NP (K (Maybe ByteString)) xs
bs) ->
      DecodeRow xs y -> NP (K (Maybe ByteString)) xs -> Either Text y
forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow (forall a. IsLabel fld a => a
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 = DecodeRow ((fld ::: ty) : row) (Maybe y)
-> MaybeT (DecodeRow ((fld ::: ty) : row)) y
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (DecodeRow ((fld ::: ty) : row) (Maybe y)
 -> MaybeT (DecodeRow ((fld ::: ty) : row)) y)
-> ((NP (K (Maybe ByteString)) ((fld ::: ty) : row)
     -> Either Text (Maybe y))
    -> DecodeRow ((fld ::: ty) : row) (Maybe y))
-> (NP (K (Maybe ByteString)) ((fld ::: ty) : row)
    -> Either Text (Maybe y))
-> MaybeT (DecodeRow ((fld ::: ty) : row)) y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP (K (Maybe ByteString)) ((fld ::: ty) : row)
 -> Either Text (Maybe y))
-> DecodeRow ((fld ::: ty) : row) (Maybe y)
forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow ((NP (K (Maybe ByteString)) ((fld ::: ty) : row)
  -> Either Text (Maybe y))
 -> MaybeT (DecodeRow ((fld ::: ty) : row)) y)
-> (NP (K (Maybe ByteString)) ((fld ::: ty) : row)
    -> Either Text (Maybe y))
-> MaybeT (DecodeRow ((fld ::: ty) : row)) y
forall a b. (a -> b) -> a -> b
$ \(SOP.K Maybe ByteString
b SOP.:* NP (K (Maybe ByteString)) xs
_) -> do
      let
        flderr :: Text
flderr = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"field name: "
          , Text
"\"", String -> Text
forall a. IsString a => String -> a
fromString (Proxy fld -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy fld
forall k (t :: k). Proxy t
SOP.Proxy @fld)), Text
"\"; "
          ]
      (Text -> Text) -> Either Text (Maybe y) -> Either Text (Maybe y)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Text
flderr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Either Text (Maybe y) -> Either Text (Maybe y))
-> Either Text (Maybe y) -> Either Text (Maybe y)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Either Text (Maybe y)
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 = DecodeRow (field : row) (Maybe y)
-> MaybeT (DecodeRow (field : row)) y
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (DecodeRow (field : row) (Maybe y)
 -> MaybeT (DecodeRow (field : row)) y)
-> ((NP (K (Maybe ByteString)) (field : row)
     -> Either Text (Maybe y))
    -> DecodeRow (field : row) (Maybe y))
-> (NP (K (Maybe ByteString)) (field : row)
    -> Either Text (Maybe y))
-> MaybeT (DecodeRow (field : row)) y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP (K (Maybe ByteString)) (field : row) -> Either Text (Maybe y))
-> DecodeRow (field : row) (Maybe y)
forall (row :: RowType) y.
(NP (K (Maybe ByteString)) row -> Either Text y) -> DecodeRow row y
decodeRow ((NP (K (Maybe ByteString)) (field : row) -> Either Text (Maybe y))
 -> MaybeT (DecodeRow (field : row)) y)
-> (NP (K (Maybe ByteString)) (field : row)
    -> Either Text (Maybe y))
-> MaybeT (DecodeRow (field : row)) y
forall a b. (a -> b) -> a -> b
$ \(K (Maybe ByteString) x
_ SOP.:* NP (K (Maybe ByteString)) xs
bs) ->
      DecodeRow xs (Maybe y)
-> NP (K (Maybe ByteString)) xs -> Either Text (Maybe y)
forall (row :: RowType) y.
DecodeRow row y -> NP (K (Maybe ByteString)) row -> Either Text y
runDecodeRow (MaybeT (DecodeRow xs) y -> DecodeRow xs (Maybe y)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall a. IsLabel fld a => a
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
    = ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
forall (row :: RowType) y.
ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
-> DecodeRow row y
DecodeRow
    (ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
 -> DecodeRow row y)
-> ((NP (K (Maybe ByteString)) row -> Except Text y)
    -> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y)
-> (NP (K (Maybe ByteString)) row -> Except Text y)
-> DecodeRow row y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NP (K (Maybe ByteString)) row -> Except Text y)
-> ReaderT (NP (K (Maybe ByteString)) row) (Except Text) y
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT
    ((NP (K (Maybe ByteString)) row -> Except Text y)
 -> DecodeRow row y)
-> (NP (K (Maybe ByteString)) row -> Except Text y)
-> DecodeRow row y
forall a b. (a -> b) -> a -> b
$ (NP P ys -> y) -> ExceptT Text Identity (NP P ys) -> Except Text y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NP P ys -> y
forall a (r :: RecordCode). IsRecord a r => RecordRep a -> a
SOP.fromRecord
    (ExceptT Text Identity (NP P ys) -> Except Text y)
-> (NP (K (Maybe ByteString)) row
    -> ExceptT Text Identity (NP P ys))
-> NP (K (Maybe ByteString)) row
-> Except Text y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (Except Text :.: P) ys -> ExceptT Text Identity (NP P ys)
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'
    (NP (Except Text :.: P) ys -> ExceptT Text Identity (NP P ys))
-> (NP (K (Maybe ByteString)) row -> NP (Except Text :.: P) ys)
-> NP (K (Maybe ByteString)) row
-> ExceptT Text Identity (NP P ys)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy FromField
-> (forall (x :: (Symbol, NullType)) (y :: (Symbol, *)).
    FromField x y =>
    K (Maybe ByteString) x -> (:.:) (Except Text) P y)
-> NP (K (Maybe ByteString)) row
-> NP (Except Text :.: P) ys
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 (Proxy FromField
forall k (t :: k). Proxy t
SOP.Proxy @FromField) (ExceptT Text Identity (P y) -> (:.:) (Except Text) P y
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
SOP.Comp (ExceptT Text Identity (P y) -> (:.:) (Except Text) P y)
-> (K (Maybe ByteString) x -> ExceptT Text Identity (P y))
-> K (Maybe ByteString) x
-> (:.:) (Except Text) P y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (Maybe ByteString) x -> ExceptT Text Identity (P y)
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.P z)
      runField :: K (Maybe ByteString) ty -> Except Text (P z)
runField = Either Text (P z) -> Except Text (P z)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text (P z) -> Except Text (P z))
-> (K (Maybe ByteString) ty -> Either Text (P z))
-> K (Maybe ByteString) ty
-> Except Text (P z)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (y :: (Symbol, *)).
FromField ty y =>
Maybe ByteString -> Either Text (P y)
forall (field :: (Symbol, NullType)) (y :: (Symbol, *)).
FromField field y =>
Maybe ByteString -> Either Text (P y)
fromField @ty (Maybe ByteString -> Either Text (P z))
-> (K (Maybe ByteString) ty -> Maybe ByteString)
-> K (Maybe ByteString) ty
-> Either Text (P z)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (Maybe ByteString) ty -> Maybe ByteString
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 :: NP (K y) labels -> StateT ByteString (Except Text) y
enumValue = Value y -> StateT ByteString (Except Text) y
forall x. Value x -> StateT ByteString (Except Text) x
devalue (Value y -> StateT ByteString (Except Text) y)
-> (NP (K y) labels -> Value y)
-> NP (K y) labels
-> StateT ByteString (Except Text) y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe y) -> Value y
forall a. (Text -> Maybe a) -> Value a
enum ((Text -> Maybe y) -> Value y)
-> (NP (K y) labels -> Text -> Maybe y)
-> NP (K y) labels
-> Value y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP (K y) labels -> Text -> Maybe y
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 :: NP (K y) labels -> Text -> Maybe y
labels = \case
    NP (K y) labels
Nil -> \Text
_ -> Maybe y
forall a. Maybe a
Nothing
    ((K y x
y :: SOP.K y label) :* NP (K y) xs
ys) -> \ Text
str ->
      if Text
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
forall a. IsString a => String -> a
fromString (Proxy x -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy x
forall k (t :: k). Proxy t
SOP.Proxy @label))
      then y -> Maybe y
forall a. a -> Maybe a
Just (K y x -> y
forall k a (b :: k). K a b -> a
SOP.unK K y x
y)
      else NP (K y) xs -> Text -> Maybe y
forall (labels :: [Symbol]) y.
All KnownSymbol labels =>
NP (K y) labels -> Text -> Maybe y
labels NP (K y) xs
ys Text
str