{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TypeOperators              #-}

-- | The types in this module have invariants which cannot be checked
-- if their constructors are in scope.  Preql.Wire exports the type
-- names only.

module Preql.Wire.Internal where

import Preql.Wire.Errors

import Control.Monad.Trans.Except
import Control.Monad.Trans.State
import Data.String (IsString)
import GHC.TypeNats
import Preql.Imports

import qualified Data.Vector.Sized as VS
import qualified Database.PostgreSQL.LibPQ as PQ

-- | The IsString instance does no validation; the limited instances
-- discourage directly manipulating strings, with the high risk of SQL
-- injection.  A @Query@ is tagged with a 'Nat' representing the width
-- of its return type.
newtype Query (n :: Nat) = Query ByteString
    deriving (Int -> Query n -> ShowS
[Query n] -> ShowS
Query n -> String
(Int -> Query n -> ShowS)
-> (Query n -> String) -> ([Query n] -> ShowS) -> Show (Query n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: Nat). Int -> Query n -> ShowS
forall (n :: Nat). [Query n] -> ShowS
forall (n :: Nat). Query n -> String
showList :: [Query n] -> ShowS
$cshowList :: forall (n :: Nat). [Query n] -> ShowS
show :: Query n -> String
$cshow :: forall (n :: Nat). Query n -> String
showsPrec :: Int -> Query n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> Query n -> ShowS
Show, String -> Query n
(String -> Query n) -> IsString (Query n)
forall a. (String -> a) -> IsString a
forall (n :: Nat). String -> Query n
fromString :: String -> Query n
$cfromString :: forall (n :: Nat). String -> Query n
IsString)

-- | @RowDecoder@ is 'Functor' but not 'Monad' so that we can index
-- the type by the number of columns that it consumes.  We also know &
-- verify all of the OIDs before we read any of the field data sent by
-- Postgres, which would admit an 'Applicative' instance but not 'Monad'
data RowDecoder (n :: Nat) a = RowDecoder (VS.Vector n PgType) (InternalDecoder a)
    deriving a -> RowDecoder n b -> RowDecoder n a
(a -> b) -> RowDecoder n a -> RowDecoder n b
(forall a b. (a -> b) -> RowDecoder n a -> RowDecoder n b)
-> (forall a b. a -> RowDecoder n b -> RowDecoder n a)
-> Functor (RowDecoder n)
forall a b. a -> RowDecoder n b -> RowDecoder n a
forall a b. (a -> b) -> RowDecoder n a -> RowDecoder n b
forall (n :: Nat) a b. a -> RowDecoder n b -> RowDecoder n a
forall (n :: Nat) a b. (a -> b) -> RowDecoder n a -> RowDecoder n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RowDecoder n b -> RowDecoder n a
$c<$ :: forall (n :: Nat) a b. a -> RowDecoder n b -> RowDecoder n a
fmap :: (a -> b) -> RowDecoder n a -> RowDecoder n b
$cfmap :: forall (n :: Nat) a b. (a -> b) -> RowDecoder n a -> RowDecoder n b
Functor

-- | Analogous to 'pure', @pureDecoder a@ returns the value @a@
-- without consuming any input from Postgres.
pureDecoder :: a -> RowDecoder 0 a
pureDecoder :: a -> RowDecoder 0 a
pureDecoder a
a = Vector 0 PgType -> InternalDecoder a -> RowDecoder 0 a
forall (n :: Nat) a.
Vector n PgType -> InternalDecoder a -> RowDecoder n a
RowDecoder Vector 0 PgType
forall a. Vector 0 a
VS.empty (a -> InternalDecoder a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | Analogous to '<*>', @pureDecoder Constructor `applyDecoder` a
-- `applyDecoder` b@ supplies two arguments to @Constructor@, from the
-- 'RowDecoder' @a@ and @b@.
applyDecoder :: RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m+n) b
applyDecoder :: RowDecoder m (a -> b) -> RowDecoder n a -> RowDecoder (m + n) b
applyDecoder (RowDecoder Vector m PgType
vm InternalDecoder (a -> b)
f) (RowDecoder Vector n PgType
vn InternalDecoder a
a) = Vector (m + n) PgType -> InternalDecoder b -> RowDecoder (m + n) b
forall (n :: Nat) a.
Vector n PgType -> InternalDecoder a -> RowDecoder n a
RowDecoder (Vector m PgType
vm Vector m PgType -> Vector n PgType -> Vector (m + n) PgType
forall (n :: Nat) (m :: Nat) a.
Vector n a -> Vector m a -> Vector (n + m) a
VS.++ Vector n PgType
vn) (InternalDecoder (a -> b)
f InternalDecoder (a -> b) -> InternalDecoder a -> InternalDecoder b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InternalDecoder a
a)

-- TODO can I use ValidationT instead of ExceptT, since I ensure Column is incremented before errors?
-- | Internal because we need IO for the libpq FFI, but we promise not
-- to do any IO besides decoding.  We don't even make network calls to
-- Postgres in @InternalDecoder@
type InternalDecoder =  StateT DecoderState (ExceptT FieldError IO)

data DecoderState = DecoderState
    { DecoderState -> Result
result :: PQ.Result
    , DecoderState -> Row
row    :: PQ.Row
    , DecoderState -> Column
column :: PQ.Column
    }
    deriving (Int -> DecoderState -> ShowS
[DecoderState] -> ShowS
DecoderState -> String
(Int -> DecoderState -> ShowS)
-> (DecoderState -> String)
-> ([DecoderState] -> ShowS)
-> Show DecoderState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecoderState] -> ShowS
$cshowList :: [DecoderState] -> ShowS
show :: DecoderState -> String
$cshow :: DecoderState -> String
showsPrec :: Int -> DecoderState -> ShowS
$cshowsPrec :: Int -> DecoderState -> ShowS
Show, DecoderState -> DecoderState -> Bool
(DecoderState -> DecoderState -> Bool)
-> (DecoderState -> DecoderState -> Bool) -> Eq DecoderState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecoderState -> DecoderState -> Bool
$c/= :: DecoderState -> DecoderState -> Bool
== :: DecoderState -> DecoderState -> Bool
$c== :: DecoderState -> DecoderState -> Bool
Eq)

decodeRow :: RowDecoder n a -> PQ.Result -> PQ.Row -> ExceptT FieldError IO a
decodeRow :: RowDecoder n a -> Result -> Row -> ExceptT FieldError IO a
decodeRow (RowDecoder Vector n PgType
_ InternalDecoder a
parsers) Result
result Row
row =
    InternalDecoder a -> DecoderState -> ExceptT FieldError IO a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT InternalDecoder a
parsers (Result -> Row -> Column -> DecoderState
DecoderState Result
result Row
row Column
0)

getNextValue :: InternalDecoder (Maybe ByteString)
getNextValue :: InternalDecoder (Maybe ByteString)
getNextValue = do
    s :: DecoderState
s@DecoderState{Result
Column
Row
column :: Column
row :: Row
result :: Result
$sel:column:DecoderState :: DecoderState -> Column
$sel:row:DecoderState :: DecoderState -> Row
$sel:result:DecoderState :: DecoderState -> Result
..} <- StateT DecoderState (ExceptT FieldError IO) DecoderState
forall (m :: * -> *) s. Monad m => StateT s m s
get
    DecoderState -> StateT DecoderState (ExceptT FieldError IO) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (DecoderState
s { $sel:column:DecoderState :: Column
column = Column
column Column -> Column -> Column
forall a. Num a => a -> a -> a
+ Column
1 } :: DecoderState)
    IO (Maybe ByteString) -> InternalDecoder (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> InternalDecoder (Maybe ByteString))
-> IO (Maybe ByteString) -> InternalDecoder (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Result -> Row -> Column -> IO (Maybe ByteString)
PQ.getvalue Result
result Row
row Column
column