{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Hasql.Interpolate.Internal.EncodeRow
  ( EncodeRow (..),
    GEncodeRow (..),
    toTable,
  )
where

import Control.Monad
import Data.Functor.Contravariant
import Data.List (intersperse)
import Data.Monoid
import GHC.Generics
import qualified Hasql.Encoders as E
import Hasql.Interpolate.Internal.EncodeRow.TH
import Hasql.Interpolate.Internal.Encoder
import Hasql.Interpolate.Internal.Sql
import Hasql.Interpolate.Internal.TH (addParam)

class EncodeRow a where
  -- | The continuation @(forall x. (a -> x -> x) -> x -> E.Params x
  -- -> Int -> r)@ is given cons @(a -> x -> x)@ and nil @(x)@ for some
  -- existential type @x@ and an encoder (@'E.Params' x@) for @x@. An
  -- Int is also given to tally up how many sql fields are in the
  -- unzipped structure.
  --
  -- ==== __Example__
  --
  -- Consider the following manually written instance:
  --
  -- @
  -- data Blerg = Blerg Int64 Bool Text Char
  --
  -- instance EncodeRow Blerg where
  --   unzipWithEncoder k = k cons nil enc 4
  --     where
  --       cons (Blerg a b c d) ~(as, bs, cs, ds) =
  --         (a : as, b : bs, c : cs, d : ds)
  --       nil = ([], [], [], [])
  --       enc =
  --              ((\(x, _, _, _) -> x) >$< param encodeField)
  --           <> ((\(_, x, _, _) -> x) >$< param encodeField)
  --           <> ((\(_, _, x, _) -> x) >$< param encodeField)
  --           <> ((\(_, _, _, x) -> x) >$< param encodeField)
  -- @
  --
  -- We chose @([Int64], [Bool], [Text], [Char])@ as our existential
  -- type. If we instead use the default instance based on
  -- 'GEncodeRow' then we would produce the same code as the
  -- instance below:
  --
  -- @
  -- instance EncodeRow Blerg where
  --   unzipWithEncoder k = k cons nil enc 4
  --     where
  --       cons (Blerg a b c d) ~(~(as, bs), ~(cs, ds)) =
  --         ((a : as, b : bs), (c : cs, d : ds))
  --       nil = (([], []), ([], []))
  --       enc =
  --              ((\((x, _),      _) -> x) >$< param encodeField)
  --           <> ((\((_, x),      _) -> x) >$< param encodeField)
  --           <> ((\(_     , (x, _)) -> x) >$< param encodeField)
  --           <> ((\(_     , (_, x)) -> x) >$< param encodeField)
  -- @
  --
  -- The notable difference being we don't produce a flat tuple, but
  -- instead produce a balanced tree of tuples isomorphic to the
  -- balanced tree of @':*:'@ from the generic 'Rep' of @Blerg@.
  unzipWithEncoder :: (forall x. (a -> x -> x) -> x -> E.Params x -> Int -> r) -> r
  default unzipWithEncoder ::
    (Generic a, GEncodeRow (Rep a)) =>
    (forall x. (a -> x -> x) -> x -> E.Params x -> Int -> r) ->
    r
  unzipWithEncoder forall x. (a -> x -> x) -> x -> Params x -> Int -> r
k = (forall x. (Rep a Any -> x -> x) -> x -> Params x -> Int -> r) -> r
forall (a :: * -> *) p r.
GEncodeRow a =>
(forall x. (a p -> x -> x) -> x -> Params x -> Int -> r) -> r
gUnzipWithEncoder \Rep a Any -> x -> x
cons x
nil Params x
enc Int
fc ->
    (a -> x -> x) -> x -> Params x -> Int -> r
forall x. (a -> x -> x) -> x -> Params x -> Int -> r
k (Rep a Any -> x -> x
cons (Rep a Any -> x -> x) -> (a -> Rep a Any) -> a -> x -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from) x
nil Params x
enc Int
fc
  {-# INLINE unzipWithEncoder #-}

class GEncodeRow a where
  gUnzipWithEncoder :: (forall x. (a p -> x -> x) -> x -> E.Params x -> Int -> r) -> r

-- | 'toTable' takes some list of products into the corresponding
-- relation in sql. It is applying the @unnest@ based technique
-- described [in the hasql
-- documentation](https://hackage.haskell.org/package/hasql-1.4.5.1/docs/Hasql-Statement.html#g:2).
--
-- ==== __Example__
--
-- Here is a small example that takes a haskell list and inserts it
-- into a table @blerg@ which has columns @x@, @y@, and @z@ of type
-- @int8@, @boolean@, and @text@ respectively.
--
-- @
-- toTableExample :: [(Int64, Bool, Text)] -> Statement () ()
-- toTableExample rowsToInsert =
--   interp [sql| insert into blerg (x, y, z) select * from ^{toTable rowsToInsert} |]
-- @
--
-- This is driven by the 'EncodeRow' type class that has a
-- default implementation for product types that are an instance of
-- 'Generic'. So the following also works:
--
-- @
-- data Blerg
--   = Blerg Int64 Bool Text
--   deriving stock (Generic)
--   deriving anyclass (EncodeRow)
--
-- toTableExample :: [Blerg] -> Statement () ()
-- toTableExample blergs =
--   interp [sql| insert into blerg (x, y, z) select * from ^{toTable blergs} |]
-- @
toTable :: EncodeRow a => [a] -> Sql
toTable :: [a] -> Sql
toTable [a]
xs = (forall x. (a -> x -> x) -> x -> Params x -> Int -> Sql) -> Sql
forall a r.
EncodeRow a =>
(forall x. (a -> x -> x) -> x -> Params x -> Int -> r) -> r
unzipWithEncoder \a -> x -> x
cons x
nil Params x
enc Int
i ->
  let unzippedEncoder :: Params ()
unzippedEncoder = (a -> x -> x) -> x -> [a] -> x
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> x -> x
cons x
nil [a]
xs x -> Params x -> Params ()
forall (f :: * -> *) b a. Contravariant f => b -> f b -> f a
>$ Params x
enc
      queryString :: StateT Int Identity Builder
queryString = Ap (StateT Int Identity) Builder -> StateT Int Identity Builder
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (StateT Int Identity) Builder -> StateT Int Identity Builder)
-> Ap (StateT Int Identity) Builder -> StateT Int Identity Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Ap (StateT Int Identity) Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
"unnest(" Ap (StateT Int Identity) Builder
-> Ap (StateT Int Identity) Builder
-> Ap (StateT Int Identity) Builder
forall a. Semigroup a => a -> a -> a
<> ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Builder] -> [Builder]) -> [Builder] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " ([Builder] -> Builder)
-> Ap (StateT Int Identity) [Builder]
-> Ap (StateT Int Identity) Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Int Identity [Builder] -> Ap (StateT Int Identity) [Builder]
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (Int -> StateT Int Identity Builder -> StateT Int Identity [Builder]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
i StateT Int Identity Builder
addParam)) Ap (StateT Int Identity) Builder
-> Ap (StateT Int Identity) Builder
-> Ap (StateT Int Identity) Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Ap (StateT Int Identity) Builder
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builder
")"
   in StateT Int Identity Builder -> Params () -> Sql
Sql StateT Int Identity Builder
queryString Params ()
unzippedEncoder
{-# INLINE toTable #-}

instance GEncodeRow x => GEncodeRow (M1 t i x) where
  gUnzipWithEncoder :: (forall x. (M1 t i x p -> x -> x) -> x -> Params x -> Int -> r)
-> r
gUnzipWithEncoder forall x. (M1 t i x p -> x -> x) -> x -> Params x -> Int -> r
k = (forall x. (x p -> x -> x) -> x -> Params x -> Int -> r) -> r
forall (a :: * -> *) p r.
GEncodeRow a =>
(forall x. (a p -> x -> x) -> x -> Params x -> Int -> r) -> r
gUnzipWithEncoder \x p -> x -> x
cons x
nil Params x
enc Int
i ->
    (M1 t i x p -> x -> x) -> x -> Params x -> Int -> r
forall x. (M1 t i x p -> x -> x) -> x -> Params x -> Int -> r
k (\(M1 x p
a) -> x p -> x -> x
cons x p
a) x
nil Params x
enc Int
i
  {-# INLINE gUnzipWithEncoder #-}

instance (GEncodeRow a, GEncodeRow b) => GEncodeRow (a :*: b) where
  gUnzipWithEncoder :: (forall x. ((:*:) a b p -> x -> x) -> x -> Params x -> Int -> r)
-> r
gUnzipWithEncoder forall x. ((:*:) a b p -> x -> x) -> x -> Params x -> Int -> r
k = (forall x. (a p -> x -> x) -> x -> Params x -> Int -> r) -> r
forall (a :: * -> *) p r.
GEncodeRow a =>
(forall x. (a p -> x -> x) -> x -> Params x -> Int -> r) -> r
gUnzipWithEncoder \a p -> x -> x
consa x
nila Params x
enca Int
ia -> (forall x. (b p -> x -> x) -> x -> Params x -> Int -> r) -> r
forall (a :: * -> *) p r.
GEncodeRow a =>
(forall x. (a p -> x -> x) -> x -> Params x -> Int -> r) -> r
gUnzipWithEncoder \b p -> x -> x
consb x
nilb Params x
encb Int
ib ->
    ((:*:) a b p -> (x, x) -> (x, x))
-> (x, x) -> Params (x, x) -> Int -> r
forall x. ((:*:) a b p -> x -> x) -> x -> Params x -> Int -> r
k
      ( \(a p
a :*: b p
b) ~(x
as, x
bs) ->
          (a p -> x -> x
consa a p
a x
as, b p -> x -> x
consb b p
b x
bs)
      )
      (x
nila, x
nilb)
      (((x, x) -> x) -> Params x -> Params (x, x)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (x, x) -> x
forall a b. (a, b) -> a
fst Params x
enca Params (x, x) -> Params (x, x) -> Params (x, x)
forall a. Semigroup a => a -> a -> a
<> ((x, x) -> x) -> Params x -> Params (x, x)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (x, x) -> x
forall a b. (a, b) -> b
snd Params x
encb)
      (Int
ia Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ib)
  {-# INLINE gUnzipWithEncoder #-}

instance EncodeField a => GEncodeRow (K1 i a) where
  gUnzipWithEncoder :: (forall x. (K1 i a p -> x -> x) -> x -> Params x -> Int -> r) -> r
gUnzipWithEncoder forall x. (K1 i a p -> x -> x) -> x -> Params x -> Int -> r
k =
    (K1 i a p -> [a] -> [a]) -> [a] -> Params [a] -> Int -> r
forall x. (K1 i a p -> x -> x) -> x -> Params x -> Int -> r
k (\(K1 a
a) [a]
b -> a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
b) [] (NullableOrNot Value [a] -> Params [a]
forall a. NullableOrNot Value a -> Params a
E.param (Value [a] -> NullableOrNot Value [a]
forall (encoder :: * -> *) a. encoder a -> NullableOrNot encoder a
E.nonNullable (NullableOrNot Value a -> Value [a]
forall (foldable :: * -> *) element.
Foldable foldable =>
NullableOrNot Value element -> Value (foldable element)
E.foldableArray NullableOrNot Value a
forall a. EncodeField a => NullableOrNot Value a
encodeField))) Int
1
  {-# INLINE gUnzipWithEncoder #-}

$(traverse genEncodeRowInstance [2 .. 8])