{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language FlexibleContexts #-}
{-# language MonoLocalBinds #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}

module Rel8.Statement.Prepared (
  input,
  prepared,
) where

-- base
import Data.Functor.Const (Const (Const), getConst)
import Data.Functor.Contravariant (contramap, (>$<))
import Data.Functor.Identity (runIdentity)
import Prelude

-- hasql
import qualified Hasql.Encoders as Hasql
import qualified Hasql.Statement as Hasql

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

-- rel8
import Rel8.Expr (Expr)
import Rel8.Expr.Opaleye (fromPrimExpr, scastExpr)
import Rel8.Schema.HTable (hfield, hspecs, htabulateA)
import Rel8.Schema.Null (Nullity (Null, NotNull))
import Rel8.Schema.Spec (Spec (..))
import Rel8.Statement (Statement)
import Rel8.Table (Table, fromColumns, toResult)
import Rel8.Table.Serialize (Serializable)
import Rel8.Type.Encoder (binary)
import Rel8.Type.Information (encode)

-- transformers
import Control.Monad.Trans.State.Strict (evalState, state)


{-| Given a 'Rel8.run' function that converts a 'Statement' to a
'Hasql.Statement', return a 'Rel8.run'-like function which instead takes a
/parameterized/ 'Statement' and converts it to a /preparable/
'Hasql.Statement'.

The parameters @i@ are sent to the database directly via PostgreSQL's binary
format. For large amounts of data this can be significantly more efficient
than embedding the values in the statement with 'Rel8.lit'.
-}
prepared :: forall a b i o.
  Serializable a i =>
  (Statement b -> Hasql.Statement () o) ->
  (a -> Statement b) ->
  Hasql.Statement i o
prepared :: forall a b i o.
Serializable a i =>
(Statement b -> Statement () o)
-> (a -> Statement b) -> Statement i o
prepared Statement b -> Statement () o
run a -> Statement b
mkStatement = ByteString -> Params i -> Result o -> Bool -> Statement i o
forall params result.
ByteString
-> Params params
-> Result result
-> Bool
-> Statement params result
Hasql.Statement ByteString
sql (forall a i. Serializable a i => Params i
encoder @a) Result o
decode Bool
True
  where
    Hasql.Statement ByteString
sql Params ()
_ Result o
decode Bool
_ = Statement b -> Statement () o
run (Statement b -> Statement () o) -> Statement b -> Statement () o
forall a b. (a -> b) -> a -> b
$ a -> Statement b
mkStatement a
forall a. Table Expr a => a
input


encoder :: forall a i. Serializable a i => Hasql.Params i
encoder :: forall a i. Serializable a i => Params i
encoder =
  (i -> Columns a Result) -> Params (Columns a Result) -> Params i
forall a' a. (a' -> a) -> Params a -> Params a'
forall (f :: Context) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @a) (Params (Columns a Result) -> Params i)
-> Params (Columns a Result) -> Params i
forall a b. (a -> b) -> a -> b
$
    Const (Params (Columns a Result)) (Columns a Any)
-> Params (Columns a Result)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Params (Columns a Result)) (Columns a Any)
 -> Params (Columns a Result))
-> Const (Params (Columns a Result)) (Columns a Any)
-> Params (Columns a Result)
forall a b. (a -> b) -> a -> b
$
      (forall a.
 HField (Columns a) a -> Const (Params (Columns a Result)) (Any a))
-> Const (Params (Columns a Result)) (Columns a Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField (Columns a) a
field ->
        case Columns a Spec -> HField (Columns a) a -> Spec a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField (Columns a) a
field of
          Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity, TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info} -> Params (Columns a Result)
-> Const (Params (Columns a Result)) (Any a)
forall {k} a (b :: k). a -> Const a b
Const (Params (Columns a Result)
 -> Const (Params (Columns a Result)) (Any a))
-> Params (Columns a Result)
-> Const (Params (Columns a Result)) (Any a)
forall a b. (a -> b) -> a -> b
$
            Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a)
-> (Columns a Result -> Identity a) -> Columns a Result -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Columns a Result -> HField (Columns a) a -> Identity a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
`hfield` HField (Columns a) a
field) (Columns a Result -> a) -> Params a -> Params (Columns a Result)
forall (f :: Context) a b.
Contravariant f =>
(a -> b) -> f b -> f a
>$<
              case Nullity a
nullity of
                Nullity a
Null -> NullableOrNot Value a -> Params a
forall a. NullableOrNot Value a -> Params a
Hasql.param (NullableOrNot Value a -> Params a)
-> NullableOrNot Value a -> Params a
forall a b. (a -> b) -> a -> b
$ Value (Unnullify a) -> NullableOrNot Value (Maybe (Unnullify a))
forall (encoder :: Context) a.
encoder a -> NullableOrNot encoder (Maybe a)
Hasql.nullable Value (Unnullify a)
build
                Nullity a
NotNull -> NullableOrNot Value a -> Params a
forall a. NullableOrNot Value a -> Params a
Hasql.param (NullableOrNot Value a -> Params a)
-> NullableOrNot Value a -> Params a
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value a
forall (encoder :: Context) a. encoder a -> NullableOrNot encoder a
Hasql.nonNullable Value a
Value (Unnullify a)
build
              where
                build :: Value (Unnullify a)
build = Encoder (Unnullify a) -> Value (Unnullify a)
forall a. Encoder a -> Value a
binary (TypeInformation (Unnullify a) -> Encoder (Unnullify a)
forall a. TypeInformation a -> Encoder a
encode TypeInformation (Unnullify a)
info)


input :: Table Expr a => a
input :: forall a. Table Expr a => a
input =
  Columns a Expr -> a
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns (Columns a Expr -> a) -> Columns a Expr -> a
forall a b. (a -> b) -> a -> b
$
    (State Word (Columns a Expr) -> Word -> Columns a Expr)
-> Word -> State Word (Columns a Expr) -> Columns a Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall s a. State s a -> s -> a
evalState @Word) Word
1 do
      (forall a. HField (Columns a) a -> StateT Word Result (Expr a))
-> State Word (Columns a Expr)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField (Columns a) a
field -> do
        Word
n <- (Word -> (Word, Word)) -> StateT Word Result Word
forall (m :: Context) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (\Word
n -> (Word
n, Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1))
        Expr a -> StateT Word Result (Expr a)
forall a. a -> StateT Word Result a
forall (f :: Context) a. Applicative f => a -> f a
pure
          case Columns a Spec -> HField (Columns a) a -> Spec a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField (Columns a) a
field of
            Spec {TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} ->
              TypeInformation (Unnullify a) -> Expr a -> Expr a
forall a. TypeInformation (Unnullify a) -> Expr a -> Expr a
scastExpr TypeInformation (Unnullify a)
info (Expr a -> Expr a) -> Expr a -> Expr a
forall a b. (a -> b) -> a -> b
$ PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a) -> PrimExpr -> Expr a
forall a b. (a -> b) -> a -> b
$
                Literal -> PrimExpr
Opaleye.ConstExpr (Literal -> PrimExpr) -> Literal -> PrimExpr
forall a b. (a -> b) -> a -> b
$ String -> Literal
Opaleye.OtherLit (String -> Literal) -> String -> Literal
forall a b. (a -> b) -> a -> b
$ Char
'$' Char -> String -> String
forall a. a -> [a] -> [a]
: Word -> String
forall a. Show a => a -> String
show Word
n