{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Module      : Polytropos.Hasql
Description : High-performance hasql PostgreSQL row decoders for Polytropos records
Copyright   : (c) 2026 The Polytropos Authors
License     : EUPL-1.2 OR Apache-2.0
Maintainer  : nadia.yvette.chambers@ik.me
Stability   : experimental
Portability : non-portable (GHC extensions)

Integrates @polytropos@ open records with the high-performance
PostgreSQL driver @hasql@.

= Architectural Overview & Rationale

== Bypassing Tuple Limits & Intermediate Allocations

Conventional database libraries map SQL rows to Haskell data types via intermediate
tuples (e.g. @(a, b, c)@). This imposes GHC's 62-column tuple limit and generates
large numbers of short-lived heap objects.

'recordRow' builds a @'Row' (Record r)@ that consumes one column per row
field, in row order, and packs the decoded values straight into the
contiguous 'Data.Primitive.SmallArray.SmallArray' payload of the record. The column decoders are
combined by the 'AllRowDecoder' constraint walk in a single pass, appending one slot
at a time. Rows of arbitrary arity (50, 100, 200+ columns) decode with zero tuple overhead.

Each column picks its value decoder from the 'Column' class at that
field's own type, allowing heterogeneous column rows.

= When to Use This Module

* When executing high-throughput PostgreSQL queries with @hasql@ where rows have
  many columns or where open records are used as query results.

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE TypeApplications #-}
>
> import qualified Hasql.Decoders as HD
> import Polytropos
> import Polytropos.Hasql
>
> type UserRow = Record '["id" ':= Int64, "age" ':= Int32]
>
> userDecoder :: HD.Row UserRow
> userDecoder = recordRow @UserRow
-}
module Polytropos.Hasql
  ( -- * Row Decoder Construction
    HasqlRow
  , recordRow

    -- * Column-Decoder Walk
  , AllRowDecoder (..)

    -- * Per-Column Value Decoders
  , Column (..)
  ) where

import Data.Functor.Identity (Identity (..))
import Data.Int              (Int16, Int32, Int64)
import Data.Kind             (Type)
import Data.Proxy            (Proxy (..))
import GHC.Exts              (Any)
import Polytropos            (Record)
import Polytropos.Core       (Pair (..), Row, RowRep (..), noInlineUnsafeCo,
                              productRep)
import Hasql.Decoders        (column, nonNullable)
import qualified Hasql.Decoders as HD

-- | hasql's row decoder monad; aliased to avoid clashing with the 'Row'
-- kind synonym from "Polytropos.Core".
type HasqlRow = HD.Row

-- | The hasql value decoder for a column of type @a@. Instances pick the
-- Postgres column type; the row walk only needs the 'column' combinator.
class Column (a :: Type) where
  columnValue :: HD.Value a

instance Column Int16 where
  columnValue :: Value Int16
columnValue = Value Int16
HD.int2

instance Column Int32 where
  columnValue :: Value Int32
columnValue = Value Int32
HD.int4

instance Column Int64 where
  columnValue :: Value Int64
columnValue = Value Int64
HD.int8

-- | Heterogeneous column walk: every field of the row @r@ has a 'Column'
-- instance at its own type. 'genRow' composes one 'Row' column decoder per
-- field, in row order, collecting the decoded values as erased payload
-- slots — a single pass, one slot appended per column, no tuples.
class AllRowDecoder (r :: Row) where
  genRow :: Proxy r -> HasqlRow [Identity Any]

instance AllRowDecoder '[] where
  genRow :: Proxy '[] -> HasqlRow [Identity Any]
genRow Proxy '[]
_ = [Identity Any] -> HasqlRow [Identity Any]
forall a. a -> Row a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (Column a, AllRowDecoder r) => AllRowDecoder ((n ':= a) ': r) where
  genRow :: Proxy ((n ':= a) : r) -> HasqlRow [Identity Any]
genRow Proxy ((n ':= a) : r)
_ =
    (\a
v [Identity Any]
vs -> Any -> Identity Any
forall a. a -> Identity a
Identity (a -> Any
forall a b. a -> b
noInlineUnsafeCo a
v :: Any) Identity Any -> [Identity Any] -> [Identity Any]
forall a. a -> [a] -> [a]
: [Identity Any]
vs)
      (a -> [Identity Any] -> [Identity Any])
-> Row a -> Row ([Identity Any] -> [Identity Any])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NullableOrNot Value a -> Row a
forall a. NullableOrNot Value a -> Row a
column (Value a -> NullableOrNot Value a
forall (decoder :: * -> *) a. decoder a -> NullableOrNot decoder a
nonNullable Value a
forall a. Column a => Value a
columnValue) :: HasqlRow a)
      Row ([Identity Any] -> [Identity Any])
-> HasqlRow [Identity Any] -> HasqlRow [Identity Any]
forall a b. Row (a -> b) -> Row a -> Row b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy r -> HasqlRow [Identity Any]
forall (r :: Row).
AllRowDecoder r =>
Proxy r -> HasqlRow [Identity Any]
genRow (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)

-- | Build a hasql row decoder that consumes one column per field of the
-- row, in row order, and materialises the record directly: the decoded
-- slots go straight into a contiguous 'Data.Primitive.SmallArray.SmallArray' payload via
-- 'productRep'. No intermediate tuples — the walk composes the column
-- decoders applicatively, so arity is unbounded.
recordRow :: forall r. AllRowDecoder r => HasqlRow (Record r)
recordRow :: forall (r :: Row). AllRowDecoder r => HasqlRow (Record r)
recordRow = Rep Identity () -> RowRep Identity 'ProductRowT r ()
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Rep Identity () -> RowRep Identity 'ProductRowT r ())
-> ([Identity Any] -> Rep Identity ())
-> [Identity Any]
-> RowRep Identity 'ProductRowT r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identity Any] -> Rep Identity ()
forall {k} (f :: * -> *) (a :: k). [f Any] -> Rep f a
productRep ([Identity Any] -> RowRep Identity 'ProductRowT r ())
-> HasqlRow [Identity Any]
-> Row (RowRep Identity 'ProductRowT r ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy r -> HasqlRow [Identity Any]
forall (r :: Row).
AllRowDecoder r =>
Proxy r -> HasqlRow [Identity Any]
genRow (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)