{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{-|
Module      : Polytropos.Beam
Description : beam schema integration for Polytropos open 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)

Enables @polytropos@ open records to act as @beam@ database schema tables
without GHC out-of-memory compilation crashes on 50+ columns.

= Architectural Overview & Rationale

== Eliminating Generic Tree Explosion in Beam

A standard beam table is a nominal Haskell record whose 'Beamable' instance is
derived through "GHC.Generics". The resulting binary metadata tree is what causes
quadratic compile times and memory blow-up on tables with 50+ columns.

In @polytropos-beam@, a table is backed by a single flat 'Data.Primitive.SmallArray.SmallArray':
* 'zipBeamFieldsM' executes as a linear lockstep walk over flat array slots.
* 'tblSkeleton' builds the table spine once per row arity.
* @t'BeamTable'@ is a zero-cost newtype wrapper around @RowRep f ProductRowT r ()@.

= When to Use This Module

* When defining large database tables (dozens or hundreds of columns) with the @beam@
  framework while maintaining predictable, instantaneous compilation.

= Worked Example

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE OverloadedRecordDot #-}
>
> import Database.Beam
> import Polytropos
> import Polytropos.Beam
>
> type UserRow = '["id" ':= Int, "username" ':= String]
> type UserTable f = BeamTable UserRow f
>
> -- 1. Construct an open record using idiomatic REC syntax:
> userRec :: Record UserRow
> userRec = REC { id = 1, username = "Alice" }
>
> -- 2. Convert to a Beam database table (zero-cost unwrap):
> userTable :: UserTable Identity
> userTable = toBeamTable userRec
>
> -- 3. Functional updates using REC_UPD prior to database serialization:
> updatedUser :: Record UserRow
> updatedUser = (REC_UPD userRec) { username = "Bob" }
>
> -- 4. Higher-Kinded Data (HKD) partial table with REC_F and REC_UPD_F:
> partialUser :: RecordF Maybe UserRow
> partialUser = REC_F { id = Just 1, username = Nothing }
>
> populatedUser :: RecordF Maybe UserRow
> populatedUser = (REC_UPD_F partialUser) { username = Just "Bob" }
-}
module Polytropos.Beam
  ( -- * Beam Tables over Polytropos Rows
    BeamTable (..)
  , toBeamTable
  , fromBeamTable
  , beamTableOfSlots

    -- * Row Introspection
  , FieldNames (..)
  ) where

import Data.Functor.Identity (Identity)
import Data.Kind             (Type)
import Data.Proxy            (Proxy (..))
import GHC.Exts              (Any, toList)
import GHC.TypeLits          (KnownSymbol, symbolVal)
import Database.Beam.Schema.Tables (Beamable (..), Columnar' (..), Ignored (..))
import Polytropos            (Record)
import Polytropos.Core       (Pair (..), Rep (..), Row, RowRep (..), RowType (..),
                              noInlineUnsafeCo, productRep, repVals)

{-------------------------------------------------------------------------------
  Row introspection
-------------------------------------------------------------------------------}

-- | The field names of a row, in row order, reified from the type level.
-- These are the default column names beam derives from the row symbols.
class FieldNames (r :: Row) where
  fieldNames :: Proxy r -> [String]

instance FieldNames '[] where
  fieldNames :: Proxy '[] -> [String]
fieldNames Proxy '[]
_ = []

instance (KnownSymbol n, FieldNames r) => FieldNames ((n ':= a) ': r) where
  fieldNames :: Proxy ((n ':= a) : r) -> [String]
fieldNames Proxy ((n ':= a) : r)
_ = Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @n) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Proxy r -> [String]
forall (r :: Row). FieldNames r => Proxy r -> [String]
fieldNames (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)

{-------------------------------------------------------------------------------
  Beam tables
-------------------------------------------------------------------------------}

-- | A @polytropos@ row presented as a beam table with column functor @f@.
--
-- Zero cost: unwraps to exactly the same t'Polytropos.Core.Rep' spine as the
-- corresponding 'Record' (for @f ~ Identity@).
newtype BeamTable (r :: Row) (f :: Type -> Type)
  = BeamTable (RowRep f ProductRowT r ())

-- | View a record as a beam table (zero-cost newtype wrap).
toBeamTable :: Record r -> BeamTable r Identity
toBeamTable :: forall (r :: Row). Record r -> BeamTable r Identity
toBeamTable (RowRep Rep Identity ()
rep) = RowRep Identity 'ProductRowT r () -> BeamTable r Identity
forall (r :: Row) (f :: * -> *).
RowRep f 'ProductRowT r () -> BeamTable r f
BeamTable (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 ()
rep)

-- | View a beam table as a record (zero-cost newtype unwrap).
fromBeamTable :: BeamTable r Identity -> Record r
fromBeamTable :: forall (r :: Row). BeamTable r Identity -> Record r
fromBeamTable (BeamTable (RowRep Rep Identity ()
rep)) = 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 ()
rep

-- | Build a table from payload slots, in row order. The slot list must have
-- exactly the row's arity; a shorter list yields a partially filled table
-- that will misbehave if traversed, so prefer 'toBeamTable'.
beamTableOfSlots :: [f Any] -> BeamTable r f
beamTableOfSlots :: forall (f :: * -> *) (r :: Row). [f Any] -> BeamTable r f
beamTableOfSlots [f Any]
slots = RowRep f 'ProductRowT r () -> BeamTable r f
forall (r :: Row) (f :: * -> *).
RowRep f 'ProductRowT r () -> BeamTable r f
BeamTable (Rep f () -> RowRep f 'ProductRowT r ()
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep ([f Any] -> Rep f ()
forall {k} (f :: * -> *) (a :: k). [f Any] -> Rep f a
productRep [f Any]
slots))

instance FieldNames r => Beamable (BeamTable r) where
  zipBeamFieldsM :: forall (m :: * -> *) (f :: * -> *) (g :: * -> *) (h :: * -> *).
Applicative m =>
(forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))
-> BeamTable r f -> BeamTable r g -> m (BeamTable r h)
zipBeamFieldsM forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine (BeamTable (RowRep (Rep Word
t SmallArray (f Any)
fv))) (BeamTable (RowRep (Rep Word
_ SmallArray (g Any)
gv))) =
    RowRep h 'ProductRowT r () -> BeamTable r h
forall (r :: Row) (f :: * -> *).
RowRep f 'ProductRowT r () -> BeamTable r f
BeamTable (RowRep h 'ProductRowT r () -> BeamTable r h)
-> ([h Any] -> RowRep h 'ProductRowT r ())
-> [h Any]
-> BeamTable r h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep h () -> RowRep h 'ProductRowT r ()
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Rep h () -> RowRep h 'ProductRowT r ())
-> ([h Any] -> Rep h ()) -> [h Any] -> RowRep h 'ProductRowT r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[h Any]
hs -> Word -> SmallArray (h Any) -> Rep h ()
forall {k} (f :: * -> *) (a :: k).
Word -> SmallArray (f Any) -> Rep f a
Rep Word
t (Rep h (ZonkAny 2) -> SmallArray (h Any)
forall {k} (f :: * -> *) (a :: k). Rep f a -> SmallArray (f Any)
repVals ([h Any] -> Rep h (ZonkAny 2)
forall {k} (f :: * -> *) (a :: k). [f Any] -> Rep f a
productRep [h Any]
hs)))
      ([h Any] -> BeamTable r h) -> m [h Any] -> m (BeamTable r h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Item (SmallArray (f Any)), Item (SmallArray (g Any)))
 -> m (h Any))
-> [(Item (SmallArray (f Any)), Item (SmallArray (g Any)))]
-> m [h Any]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Item (SmallArray (f Any)), Item (SmallArray (g Any))) -> m (h Any)
step ([Item (SmallArray (f Any))]
-> [Item (SmallArray (g Any))]
-> [(Item (SmallArray (f Any)), Item (SmallArray (g Any)))]
forall a b. [a] -> [b] -> [(a, b)]
zip (SmallArray (f Any) -> [Item (SmallArray (f Any))]
forall l. IsList l => l -> [Item l]
toList SmallArray (f Any)
fv) (SmallArray (g Any) -> [Item (SmallArray (g Any))]
forall l. IsList l => l -> [Item l]
toList SmallArray (g Any)
gv))
    where
      -- The erased-slot coercions: Columnar' f a is a newtype around
      -- Columnar f a, which for a concrete f is f a — so a slot of type
      -- f Any and a Columnar' f Any dictionary have identical runtime
      -- representation. The @a@ is fixed to Any by the rebuild below.
      step :: (Item (SmallArray (f Any)), Item (SmallArray (g Any))) -> m (h Any)
step (Item (SmallArray (f Any))
fx, Item (SmallArray (g Any))
gx) =
        (Columnar' h (ZonkAny 0) -> h Any)
-> m (Columnar' h (ZonkAny 0)) -> m (h Any)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Columnar' Columnar h (ZonkAny 0)
hx) -> Columnar h (ZonkAny 0) -> h Any
forall a b. a -> b
noInlineUnsafeCo Columnar h (ZonkAny 0)
hx :: h Any)
             (Columnar' f (ZonkAny 0)
-> Columnar' g (ZonkAny 0) -> m (Columnar' h (ZonkAny 0))
forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)
combine (Item (SmallArray (f Any)) -> Columnar' f (ZonkAny 0)
forall a b. a -> b
noInlineUnsafeCo Item (SmallArray (f Any))
fx) (Item (SmallArray (g Any)) -> Columnar' g (ZonkAny 0)
forall a b. a -> b
noInlineUnsafeCo Item (SmallArray (g Any))
gx))
  {-# INLINE zipBeamFieldsM #-}

  tblSkeleton :: TableSkeleton (BeamTable r)
tblSkeleton =
    RowRep Ignored 'ProductRowT r () -> TableSkeleton (BeamTable r)
forall (r :: Row) (f :: * -> *).
RowRep f 'ProductRowT r () -> BeamTable r f
BeamTable (Rep Ignored () -> RowRep Ignored 'ProductRowT r ()
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep ([Ignored Any] -> Rep Ignored ()
forall {k} (f :: * -> *) (a :: k). [f Any] -> Rep f a
productRep (Int -> Ignored Any -> [Ignored Any]
forall a. Int -> a -> [a]
replicate ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Proxy r -> [String]
forall (r :: Row). FieldNames r => Proxy r -> [String]
fieldNames (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r))) Ignored Any
forall x. Ignored x
Ignored)))