{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilies          #-}

module Preql.FromSql.Class where

import Preql.Wire.Errors
import Preql.Wire.Internal

import Control.Exception (throwIO)
import Control.Monad.Except
import Control.Monad.Trans.Reader (ask)
import Data.IORef (readIORef)
import GHC.TypeNats
import qualified BinaryParser as BP
import qualified Data.Vector.Sized as VS
import qualified Database.PostgreSQL.LibPQ as PQ

-- | A @FieldDecoder@ for a type @a@ consists of an OID indicating the
-- Postgres type which can be decoded, and a parser from the binary
-- representation of that type to the Haskell representation.
data FieldDecoder a = FieldDecoder PgType (BP.BinaryParser a)
    deriving a -> FieldDecoder b -> FieldDecoder a
(a -> b) -> FieldDecoder a -> FieldDecoder b
(forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b)
-> (forall a b. a -> FieldDecoder b -> FieldDecoder a)
-> Functor FieldDecoder
forall a b. a -> FieldDecoder b -> FieldDecoder a
forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FieldDecoder b -> FieldDecoder a
$c<$ :: forall a b. a -> FieldDecoder b -> FieldDecoder a
fmap :: (a -> b) -> FieldDecoder a -> FieldDecoder b
$cfmap :: forall a b. (a -> b) -> FieldDecoder a -> FieldDecoder b
Functor

class FromSqlField a where
    fromSqlField :: FieldDecoder a

-- | A type which can be decoded from a SQL row.  Note that this
-- includes the canonical order of fields.
--
-- The default (empty) instance works for any type with a
-- 'FromSqlField' instance
class FromSql a where
    -- | The number of columns read in decoding this type.
    type Width a :: Nat
    type Width a = 1
    {-# INLINE fromSql #-}
    fromSql :: RowDecoder (Width a) a
    default fromSql :: (FromSqlField a, Width a ~ 1) => RowDecoder (Width a) a
    fromSql = FieldDecoder a -> RowDecoder 1 a
forall a. FieldDecoder a -> RowDecoder 1 a
notNull FieldDecoder a
forall a. FromSqlField a => FieldDecoder a
fromSqlField

-- | Construct a decoder for a single non-nullable column.
{-# INLINE notNull #-}
notNull :: FieldDecoder a -> RowDecoder 1 a
notNull :: FieldDecoder a -> RowDecoder 1 a
notNull (FieldDecoder PgType
oid BinaryParser a
parser) = {-# SCC "notNull" #-} Vector 1 PgType -> InternalDecoder a -> RowDecoder 1 a
forall (n :: Nat) a.
Vector n PgType -> InternalDecoder a -> RowDecoder n a
RowDecoder (PgType -> Vector 1 PgType
forall a. a -> Vector 1 a
VS.singleton PgType
oid) (InternalDecoder a -> RowDecoder 1 a)
-> InternalDecoder a -> RowDecoder 1 a
forall a b. (a -> b) -> a -> b
$ do
    Maybe ByteString
m_bs <- InternalDecoder (Maybe ByteString)
getNextValue
    case Maybe ByteString
m_bs of
        Maybe ByteString
Nothing -> UnlocatedFieldError -> InternalDecoder a
forall a. UnlocatedFieldError -> InternalDecoder a
throwLocated UnlocatedFieldError
UnexpectedNull
        Just ByteString
bs -> (Text -> InternalDecoder a)
-> (a -> InternalDecoder a) -> Either Text a -> InternalDecoder a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (UnlocatedFieldError -> InternalDecoder a
forall a. UnlocatedFieldError -> InternalDecoder a
throwLocated (UnlocatedFieldError -> InternalDecoder a)
-> (Text -> UnlocatedFieldError) -> Text -> InternalDecoder a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnlocatedFieldError
ParseFailure) a -> InternalDecoder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BinaryParser a -> ByteString -> Either Text a
forall a. BinaryParser a -> ByteString -> Either Text a
BP.run BinaryParser a
parser ByteString
bs)

-- | Construct a decoder for a single nullable column.
{-# INLINE nullable #-}
nullable :: FieldDecoder a -> RowDecoder 1 (Maybe a)
nullable :: FieldDecoder a -> RowDecoder 1 (Maybe a)
nullable (FieldDecoder PgType
oid BinaryParser a
parser) = {-# SCC "nullable" #-} Vector 1 PgType
-> InternalDecoder (Maybe a) -> RowDecoder 1 (Maybe a)
forall (n :: Nat) a.
Vector n PgType -> InternalDecoder a -> RowDecoder n a
RowDecoder (PgType -> Vector 1 PgType
forall a. a -> Vector 1 a
VS.singleton PgType
oid) (InternalDecoder (Maybe a) -> RowDecoder 1 (Maybe a))
-> InternalDecoder (Maybe a) -> RowDecoder 1 (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
    Maybe ByteString
m_bs <- InternalDecoder (Maybe ByteString)
getNextValue
    case Maybe ByteString
m_bs of
        Maybe ByteString
Nothing -> Maybe a -> InternalDecoder (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Just ByteString
bs -> (Text -> InternalDecoder (Maybe a))
-> (a -> InternalDecoder (Maybe a))
-> Either Text a
-> InternalDecoder (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (UnlocatedFieldError -> InternalDecoder (Maybe a)
forall a. UnlocatedFieldError -> InternalDecoder a
throwLocated (UnlocatedFieldError -> InternalDecoder (Maybe a))
-> (Text -> UnlocatedFieldError)
-> Text
-> InternalDecoder (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UnlocatedFieldError
ParseFailure) (Maybe a -> InternalDecoder (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> InternalDecoder (Maybe a))
-> (a -> Maybe a) -> a -> InternalDecoder (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) (BinaryParser a -> ByteString -> Either Text a
forall a. BinaryParser a -> ByteString -> Either Text a
BP.run BinaryParser a
parser ByteString
bs)

{-# INLINE throwLocated #-}
throwLocated :: UnlocatedFieldError -> InternalDecoder a
throwLocated :: UnlocatedFieldError -> InternalDecoder a
throwLocated UnlocatedFieldError
fieldError = {-# SCC "throwLocated" #-} do
    DecoderState{$sel:row:DecoderState :: DecoderState -> Row
row = PQ.Row CInt
r, $sel:column:DecoderState :: DecoderState -> Column
column = PQ.Col CInt
c} <- IO DecoderState -> ReaderT (IORef DecoderState) IO DecoderState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO DecoderState -> ReaderT (IORef DecoderState) IO DecoderState)
-> (IORef DecoderState -> IO DecoderState)
-> IORef DecoderState
-> ReaderT (IORef DecoderState) IO DecoderState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef DecoderState -> IO DecoderState
forall a. IORef a -> IO a
readIORef (IORef DecoderState
 -> ReaderT (IORef DecoderState) IO DecoderState)
-> ReaderT (IORef DecoderState) IO (IORef DecoderState)
-> ReaderT (IORef DecoderState) IO DecoderState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT (IORef DecoderState) IO (IORef DecoderState)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    IO a -> InternalDecoder a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> InternalDecoder a) -> IO a -> InternalDecoder a
forall a b. (a -> b) -> a -> b
$ FieldError -> IO a
forall e a. Exception e => e -> IO a
throwIO (Int -> Int -> UnlocatedFieldError -> FieldError
FieldError (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
r) (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
c) UnlocatedFieldError
fieldError)