{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Description: newtype to support FromSql instances for row types.

module Preql.FromSql.Tuple where

import Preql.FromSql.Class (FieldDecoder(..))
import Preql.Wire.Errors (PgType(..))

import Control.Monad (unless)
import Data.Bits ((.|.), Bits, shiftL)
import Data.Int (Int32)
import qualified BinaryParser as BP
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Database.PostgreSQL.LibPQ as PQ

-- | Wrapper for Postgres anonymous row types (sometimes called record
-- types), so instance resolution picks the right decoder.  The useful
-- instances are for (Haskell) tuples.  Postgres allows row types with
-- a single field, but the instances would overlap with those for
-- nested row types, so we do not provide them.
newtype Tuple r = Tuple r
  deriving (Tuple r -> Tuple r -> Bool
(Tuple r -> Tuple r -> Bool)
-> (Tuple r -> Tuple r -> Bool) -> Eq (Tuple r)
forall r. Eq r => Tuple r -> Tuple r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tuple r -> Tuple r -> Bool
$c/= :: forall r. Eq r => Tuple r -> Tuple r -> Bool
== :: Tuple r -> Tuple r -> Bool
$c== :: forall r. Eq r => Tuple r -> Tuple r -> Bool
Eq, Eq (Tuple r)
Eq (Tuple r)
-> (Tuple r -> Tuple r -> Ordering)
-> (Tuple r -> Tuple r -> Bool)
-> (Tuple r -> Tuple r -> Bool)
-> (Tuple r -> Tuple r -> Bool)
-> (Tuple r -> Tuple r -> Bool)
-> (Tuple r -> Tuple r -> Tuple r)
-> (Tuple r -> Tuple r -> Tuple r)
-> Ord (Tuple r)
Tuple r -> Tuple r -> Bool
Tuple r -> Tuple r -> Ordering
Tuple r -> Tuple r -> Tuple r
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall r. Ord r => Eq (Tuple r)
forall r. Ord r => Tuple r -> Tuple r -> Bool
forall r. Ord r => Tuple r -> Tuple r -> Ordering
forall r. Ord r => Tuple r -> Tuple r -> Tuple r
min :: Tuple r -> Tuple r -> Tuple r
$cmin :: forall r. Ord r => Tuple r -> Tuple r -> Tuple r
max :: Tuple r -> Tuple r -> Tuple r
$cmax :: forall r. Ord r => Tuple r -> Tuple r -> Tuple r
>= :: Tuple r -> Tuple r -> Bool
$c>= :: forall r. Ord r => Tuple r -> Tuple r -> Bool
> :: Tuple r -> Tuple r -> Bool
$c> :: forall r. Ord r => Tuple r -> Tuple r -> Bool
<= :: Tuple r -> Tuple r -> Bool
$c<= :: forall r. Ord r => Tuple r -> Tuple r -> Bool
< :: Tuple r -> Tuple r -> Bool
$c< :: forall r. Ord r => Tuple r -> Tuple r -> Bool
compare :: Tuple r -> Tuple r -> Ordering
$ccompare :: forall r. Ord r => Tuple r -> Tuple r -> Ordering
$cp1Ord :: forall r. Ord r => Eq (Tuple r)
Ord, Int -> Tuple r -> ShowS
[Tuple r] -> ShowS
Tuple r -> String
(Int -> Tuple r -> ShowS)
-> (Tuple r -> String) -> ([Tuple r] -> ShowS) -> Show (Tuple r)
forall r. Show r => Int -> Tuple r -> ShowS
forall r. Show r => [Tuple r] -> ShowS
forall r. Show r => Tuple r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tuple r] -> ShowS
$cshowList :: forall r. Show r => [Tuple r] -> ShowS
show :: Tuple r -> String
$cshow :: forall r. Show r => Tuple r -> String
showsPrec :: Int -> Tuple r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> Tuple r -> ShowS
Show)

-- Unlike the same-named functions in PostgreSQL.Binary.Decoding, these check
-- the number of components and the OIDs of each component.

-- | Helper for decoding composites
newtype Composite a = Composite (BP.BinaryParser a)
  deriving newtype (a -> Composite b -> Composite a
(a -> b) -> Composite a -> Composite b
(forall a b. (a -> b) -> Composite a -> Composite b)
-> (forall a b. a -> Composite b -> Composite a)
-> Functor Composite
forall a b. a -> Composite b -> Composite a
forall a b. (a -> b) -> Composite a -> Composite b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Composite b -> Composite a
$c<$ :: forall a b. a -> Composite b -> Composite a
fmap :: (a -> b) -> Composite a -> Composite b
$cfmap :: forall a b. (a -> b) -> Composite a -> Composite b
Functor, Functor Composite
a -> Composite a
Functor Composite
-> (forall a. a -> Composite a)
-> (forall a b. Composite (a -> b) -> Composite a -> Composite b)
-> (forall a b c.
    (a -> b -> c) -> Composite a -> Composite b -> Composite c)
-> (forall a b. Composite a -> Composite b -> Composite b)
-> (forall a b. Composite a -> Composite b -> Composite a)
-> Applicative Composite
Composite a -> Composite b -> Composite b
Composite a -> Composite b -> Composite a
Composite (a -> b) -> Composite a -> Composite b
(a -> b -> c) -> Composite a -> Composite b -> Composite c
forall a. a -> Composite a
forall a b. Composite a -> Composite b -> Composite a
forall a b. Composite a -> Composite b -> Composite b
forall a b. Composite (a -> b) -> Composite a -> Composite b
forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite 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
<* :: Composite a -> Composite b -> Composite a
$c<* :: forall a b. Composite a -> Composite b -> Composite a
*> :: Composite a -> Composite b -> Composite b
$c*> :: forall a b. Composite a -> Composite b -> Composite b
liftA2 :: (a -> b -> c) -> Composite a -> Composite b -> Composite c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Composite a -> Composite b -> Composite c
<*> :: Composite (a -> b) -> Composite a -> Composite b
$c<*> :: forall a b. Composite (a -> b) -> Composite a -> Composite b
pure :: a -> Composite a
$cpure :: forall a. a -> Composite a
$cp1Applicative :: Functor Composite
Applicative)

composite :: Int -> Composite a -> BP.BinaryParser a
composite :: Int -> Composite a -> BinaryParser a
composite Int
n (Composite BinaryParser a
parser) = do
  Int
size <- Int -> BinaryParser Int
forall a. (Integral a, Bits a) => Int -> BinaryParser a
intOfSize Int
4
  Bool -> BinaryParser () -> BinaryParser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n) (Text -> BinaryParser ()
forall a. Text -> BinaryParser a
BP.failure Text
"composite has wrong size")
  BinaryParser a
parser

valueComposite :: FieldDecoder a -> Composite a
valueComposite :: FieldDecoder a -> Composite a
valueComposite (FieldDecoder PgType
pgType BinaryParser a
parser) = BinaryParser a -> Composite a
forall a. BinaryParser a -> Composite a
Composite (BinaryParser a -> Composite a) -> BinaryParser a -> Composite a
forall a b. (a -> b) -> a -> b
$ do
  case PgType
pgType of
    -- For now, we only confirm statically-known OIDs.  To do more, we'll need
    -- to feed through the OID cache (not yet implemented) and the Connection
    -- (which will be a problem if we ever implement lazy decoding)
    -- Statically-known OIDs seems like a reasonable compromise for now, until
    -- other parts of the design stabilize.
    Oid (PQ.Oid CUInt
expected) Oid
_ -> do
      CUInt
actual <- Int -> BinaryParser CUInt
forall a. (Integral a, Bits a) => Int -> BinaryParser a
intOfSize Int
4
      Bool -> BinaryParser () -> BinaryParser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CUInt
actual CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== CUInt
expected) (Text -> BinaryParser ()
forall a. Text -> BinaryParser a
BP.failure (Text -> BinaryParser ()) -> Text -> BinaryParser ()
forall a b. (a -> b) -> a -> b
$ Text
"OID in composite expected=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CUInt -> Text
showt CUInt
expected Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" actual=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CUInt -> Text
showt CUInt
actual)
    TypeName Text
_ -> Int -> BinaryParser ()
BP.unitOfSize Int
4 -- TODO check cache, maybe query DB
  BinaryParser a -> BinaryParser (Maybe a)
forall a. BinaryParser a -> BinaryParser (Maybe a)
onContent BinaryParser a
parser BinaryParser (Maybe a)
-> (Maybe a -> BinaryParser a) -> BinaryParser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    BinaryParser a
-> (a -> BinaryParser a) -> Maybe a -> BinaryParser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> BinaryParser a
forall a. Text -> BinaryParser a
BP.failure Text
"unexpected null") a -> BinaryParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  where showt :: CUInt -> Text
showt = String -> Text
T.pack (String -> Text) -> (CUInt -> String) -> CUInt -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CUInt -> String
forall a. Show a => a -> String
show

{-# INLINE intOfSize #-}
intOfSize :: (Integral a, Bits a) => Int -> BP.BinaryParser a
intOfSize :: Int -> BinaryParser a
intOfSize Int
x =
  (ByteString -> a) -> BinaryParser ByteString -> BinaryParser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Word8 -> a) -> a -> ByteString -> a
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\a
n Word8
h -> a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftL a
n Int
8 a -> a -> a
forall a. Bits a => a -> a -> a
.|. Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h) a
0) (Int -> BinaryParser ByteString
BP.bytesOfSize Int
x)

{-# INLINABLE onContent #-}
onContent :: BP.BinaryParser a -> BP.BinaryParser ( Maybe a )
onContent :: BinaryParser a -> BinaryParser (Maybe a)
onContent BinaryParser a
decoder = do
  Int32
size :: Int32 <- Int -> BinaryParser Int32
forall a. (Integral a, Bits a) => Int -> BinaryParser a
intOfSize Int
4
  case Int32
size of
    (-1) -> Maybe a -> BinaryParser (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Int32
n -> (a -> Maybe a) -> BinaryParser a -> BinaryParser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Int -> BinaryParser a -> BinaryParser a
forall a. Int -> BinaryParser a -> BinaryParser a
BP.sized (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n) BinaryParser a
decoder)