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

module Preql.FromSql.Class where

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

import Control.Monad.Except
import Control.Monad.Trans.State
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
    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.
notNull :: FieldDecoder a -> RowDecoder 1 a
notNull :: FieldDecoder a -> RowDecoder 1 a
notNull (FieldDecoder PgType
oid BinaryParser a
parser) = 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.
nullable :: FieldDecoder a -> RowDecoder 1 (Maybe a)
nullable :: FieldDecoder a -> RowDecoder 1 (Maybe a)
nullable (FieldDecoder PgType
oid BinaryParser a
parser) = 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)

throwLocated :: UnlocatedFieldError -> InternalDecoder a
throwLocated :: UnlocatedFieldError -> InternalDecoder a
throwLocated UnlocatedFieldError
fieldError = do
    DecoderState{$sel:row:DecoderState :: DecoderState -> Row
row = PQ.Row CInt
r, $sel:column:DecoderState :: DecoderState -> Column
column = PQ.Col CInt
c} <- StateT DecoderState (ExceptT FieldError IO) DecoderState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    FieldError -> InternalDecoder a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (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)