{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Module      : Polytropos.Generics
Description : Generic deriving, representation bridging, and whole-data traversal for Polytropos
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)

Generic deriving, representation bridging, and structural traversal engine for
@polytropos@.

This module bridges nominal Haskell algebraic data types (ADTs) to and from the
unified flat representation @t'Polytropos.Core.Rep'@, and provides zero-overhead
structural operations (@'geq'@, @'gcompare'@, @'gshowsPrec'@, @'gmap'@, @'gfoldMap'@)
across both open rows (@t'RowRep'@, @Record@, @Variant@) and nominal types.

= Architectural Overview & Rationale

== Why does @polytropos-generics@ resemble built-in "GHC.Generics" rather than @large-generics@?

=== 1. Unified Sums and Products vs. Records-Only

Libraries such as @large-generics@ (@Data.Record.Generic@) are strictly
single-constructor /record/ (product) libraries. Their representation
@Rep f a = Rep (SmallArray (f Any))@ lacks a constructor tag entirely,
preventing them from representing sum types, variants, or multi-constructor ADTs.
Furthermore, their dictionary abstraction @dict :: Proxy c -> Rep (Dict c) a@
is a 1D vector corresponding only to the fields of that single constructor.

In contrast, @polytropos@ collapses products and sums into a single uniform mechanism:

@
data Rep (f :: Type -> Type) a = Rep {-# UNPACK #-} !Word !(SmallArray (f Any))
@

* In a product (record), the constructor tag is @0@, and the array carries all fields.
* In a sum (variant), the constructor tag corresponds to the constructor index, and the
  array carries that constructor's payloads.

Because types may have multiple constructors, dictionary resolution in @polytropos-generics@
is organized as a __2D dictionary matrix__:

@
class GInstances (c :: Type -> Constraint) a where
  gdicts :: SmallArray (SmallArray (DictAny c))
@

The outer array is indexed in \(O(1)\) by the constructor tag @tx :: Word@; the inner array
supplies the field dictionaries for that specific constructor.

=== 2. Flat Runtime Arrays vs. Binary Type-Tree Overhead

While standard "GHC.Generics" provides a simple @Generic(from, to)@ mental model,
it compiles down to deeply nested binary type trees (@(:*:)@, @(:+:)@, @M1@, @K1@).
For types with many fields or constructors, this causes \(O(2^N)\) compile-time metadata
blow-up and substantial runtime pointer-chasing and heap allocation.

@polytropos-generics@ adopts the intuitive @Generic(from, to)@ interface, but
maps directly to flat contiguous memory. Generic operations run as tight unrolled loops
over 'Data.Primitive.SmallArray.SmallArray' with literal dictionary dispatch.

= When to Use This Module

* __Whole-Data Operations on Open Rows__: When you need structural equality (@'geq'@),
  ordering (@'gcompare'@), rendering (@'gshowsPrec'@), or uniform mapping (@'gmap'@,
  @'gfoldMap'@) over open @Record@ or @Variant@ types without writing manual boilerplate.
* __Bridging Nominal ADTs__: When translating nominal Haskell data types into flat
  polytropos arrays for serialization (e.g. CBOR, Aeson), database marshalling (Hasql,
  Rel8, Beam), or open effect payload carrier systems.

= When Not to Use This Module

* When working purely with individual field access and modification on open rows; use
  the optics satellites (@polytropos-optics@, @polytropos-lens@, or @polytropos-microlens@)
  or the core field projection functions instead.
* When working with records that require SOP n-ary product combinators (@NP@, @czipWith@)
  over heterogeneous functors without sum representations; in those cases, specialized
  product generics may be preferred.

= Worked Examples

== Mode A: Whole-Data Operations over Open Rows

Open records and variants already provide built-in instances of 'Generic' and
'GInstances' via the typechecker plugin's 'AllFields' evidence synthesis:

> {-# LANGUAGE DataKinds #-}
>
> import Polytropos
> import Polytropos.Generics
>
> -- Create an open record using idiomatic REC syntax:
> person :: Record '["name" ':= String, "age" ':= Int]
> person = REC { name = "Alice", age = 30 }
>
> -- 1. Structural equality:
> isEqual :: Bool
> isEqual = geq person person  -- True
>
> -- 2. Uniform type-directed mapping:
> -- Double every numeric field in a record:
> doubled :: Record '["x" ':= Int, "y" ':= Int]
> doubled = gmap @Num (* 2) (REC { x = 10, y = 20 })
>
> -- 3. Folding across heterogeneous fields:
> summary :: String
> summary = gfoldMap @Show (\x -> show x ++ "; ") person
> -- Evaluates to: "\"Alice\"; 30; "

== Mode B: Bridging Nominal ADTs

Nominal Haskell types can implement 'Generic' and 'GInstances' to participate in
flat array-based generic routines:

> {-# LANGUAGE TypeApplications #-}
>
> import Polytropos.Core
> import Polytropos.Generics
> import Data.Primitive.SmallArray
> import Unsafe.Coerce (unsafeCoerce)
>
> data Shape = Circle Double | Rectangle Double Double
>   deriving (Show, Eq)
>
> instance Generic Shape where
>   type RepOf Shape = Rep I Shape
>   from (Circle r)        = Rep 0 (smallArrayFromList [I (unsafeCoerce r)])
>   from (Rectangle w h)   = Rep 1 (smallArrayFromList [I (unsafeCoerce w), I (unsafeCoerce h)])
>   to (Rep 0 arr)         = let I r = indexSmallArray arr 0 in Circle (unsafeCoerce r)
>   to (Rep 1 arr)         = let I w = indexSmallArray arr 0; I h = indexSmallArray arr 1 in Rectangle (unsafeCoerce w) (unsafeCoerce h)
>   to _                   = error "invalid constructor tag"
>
> instance GInstances Eq Shape where
>   gdicts = smallArrayFromList
>     [ smallArrayFromList [mkDictAny @Eq @Double]
>     , smallArrayFromList [mkDictAny @Eq @Double, mkDictAny @Eq @Double]
>     ]
>
> -- Usage:
> -- geq (Circle 5.0) (Circle 5.0) == True
-}
module Polytropos.Generics (
    -- * Generic Conversion Class
    Generic(..)
  , I(..)

    -- * Dictionary Supply Matrix
  , GInstances(..)

    -- * Generic Structural Operations
    -- ** Equality and Ordering
  , geq
  , gcompare

    -- ** Pretty Printing
  , gshowsPrec

    -- ** Functorial Mapping and Folding
  , gmap
  , gfoldMap
  ) where

import Data.Functor.Identity (Identity(..))
import Data.Kind (Constraint, Type)
import Data.Primitive.SmallArray
import GHC.Exts (Any)
import Polytropos.Core
  ( DictAny(..)
  , Rep(..)
  , RowRep(..)
  , RowType(..)
  , AllFields(..)
  , noInlineUnsafeCo
  )

-- | Identity functor for use with t'Polytropos.Core.Rep'.
newtype I a = I { forall a. I a -> a
unI :: a }

-- | Generic conversion class. Bridges nominal ADTs to t'Polytropos.Core.Rep'.
class Generic a where
  type RepOf a :: Type
  from :: a -> RepOf a
  to   :: RepOf a -> a

-- | Provides an array of constraint dictionaries for each constructor of @a@,
-- and for each field within that constructor.
class GInstances (c :: Type -> Constraint) a where
  gdicts :: SmallArray (SmallArray (DictAny c))

-- CPS helpers to avoid ambiguity
withDictEq :: DictAny Eq -> Any -> Any -> Bool
withDictEq :: DictAny Eq -> Any -> Any -> Bool
withDictEq DictAny Eq
d Any
x Any
y = case DictAny Eq
d of DictAny Eq
DictAny -> Any
x Any -> Any -> Bool
forall a. Eq a => a -> a -> Bool
== Any
y

withDictOrd :: DictAny Ord -> Any -> Any -> Ordering
withDictOrd :: DictAny Ord -> Any -> Any -> Ordering
withDictOrd DictAny Ord
d Any
x Any
y = case DictAny Ord
d of DictAny Ord
DictAny -> Any -> Any -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Any
x Any
y

withDictShow :: DictAny Show -> Any -> Int -> ShowS
withDictShow :: DictAny Show -> Any -> Int -> ShowS
withDictShow DictAny Show
d Any
x Int
p = case DictAny Show
d of DictAny Show
DictAny -> Int -> Any -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Any
x

withDictMap :: DictAny c -> (forall x. c x => x -> x) -> Any -> Any
withDictMap :: forall (c :: * -> Constraint).
DictAny c -> (forall x. c x => x -> x) -> Any -> Any
withDictMap DictAny c
d forall x. c x => x -> x
f Any
x = case DictAny c
d of DictAny c
DictAny -> Any -> Any
forall x. c x => x -> x
f Any
x

withDictFoldMap :: DictAny c -> (forall x. c x => x -> m) -> Any -> m
withDictFoldMap :: forall (c :: * -> Constraint) m.
DictAny c -> (forall x. c x => x -> m) -> Any -> m
withDictFoldMap DictAny c
d forall x. c x => x -> m
f Any
x = case DictAny c
d of DictAny c
DictAny -> Any -> m
forall x. c x => x -> m
f Any
x

-- | Generic equality using the 'Eq' class.
geq :: forall a. (Generic a, RepOf a ~ Rep I a, GInstances Eq a) => a -> a -> Bool
geq :: forall a.
(Generic a, RepOf a ~ Rep I a, GInstances Eq a) =>
a -> a -> Bool
geq a
x a
y =
  let Rep Word
tx SmallArray (I Any)
vx = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
x
      Rep Word
ty SmallArray (I Any)
vy = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
y
  in Word
tx Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
ty Bool -> Bool -> Bool
&&
     let dicts :: SmallArray (DictAny Eq)
dicts = SmallArray (SmallArray (DictAny Eq))
-> Int -> SmallArray (DictAny Eq)
forall a. SmallArray a -> Int -> a
indexSmallArray (forall {k} (c :: * -> Constraint) (a :: k).
GInstances c a =>
SmallArray (SmallArray (DictAny c))
forall (c :: * -> Constraint) a.
GInstances c a =>
SmallArray (SmallArray (DictAny c))
gdicts @Eq @a) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tx)
     in SmallArray (DictAny Eq)
-> SmallArray (I Any) -> SmallArray (I Any) -> Int -> Int -> Bool
loop SmallArray (DictAny Eq)
dicts SmallArray (I Any)
vx SmallArray (I Any)
vy Int
0 (SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
vx)
  where
    loop :: SmallArray (DictAny Eq)
-> SmallArray (I Any) -> SmallArray (I Any) -> Int -> Int -> Bool
loop SmallArray (DictAny Eq)
dicts SmallArray (I Any)
vx SmallArray (I Any)
vy Int
i Int
n
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Bool
True
      | Bool
otherwise =
          let d :: DictAny Eq
d = SmallArray (DictAny Eq) -> Int -> DictAny Eq
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (DictAny Eq)
dicts Int
i
              I Any
vx_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vx Int
i
              I Any
vy_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vy Int
i
          in DictAny Eq -> Any -> Any -> Bool
withDictEq DictAny Eq
d Any
vx_i Any
vy_i Bool -> Bool -> Bool
&& SmallArray (DictAny Eq)
-> SmallArray (I Any) -> SmallArray (I Any) -> Int -> Int -> Bool
loop SmallArray (DictAny Eq)
dicts SmallArray (I Any)
vx SmallArray (I Any)
vy (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
n

-- | Generic comparison using the 'Ord' class.
gcompare :: forall a. (Generic a, RepOf a ~ Rep I a, GInstances Ord a) => a -> a -> Ordering
gcompare :: forall a.
(Generic a, RepOf a ~ Rep I a, GInstances Ord a) =>
a -> a -> Ordering
gcompare a
x a
y =
  let Rep Word
tx SmallArray (I Any)
vx = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
x
      Rep Word
ty SmallArray (I Any)
vy = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
y
  in Word -> Word -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word
tx Word
ty Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<>
     let dicts :: SmallArray (DictAny Ord)
dicts = SmallArray (SmallArray (DictAny Ord))
-> Int -> SmallArray (DictAny Ord)
forall a. SmallArray a -> Int -> a
indexSmallArray (forall {k} (c :: * -> Constraint) (a :: k).
GInstances c a =>
SmallArray (SmallArray (DictAny c))
forall (c :: * -> Constraint) a.
GInstances c a =>
SmallArray (SmallArray (DictAny c))
gdicts @Ord @a) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tx)
     in SmallArray (DictAny Ord)
-> SmallArray (I Any)
-> SmallArray (I Any)
-> Int
-> Int
-> Ordering
loop SmallArray (DictAny Ord)
dicts SmallArray (I Any)
vx SmallArray (I Any)
vy Int
0 (SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
vx)
  where
    loop :: SmallArray (DictAny Ord)
-> SmallArray (I Any)
-> SmallArray (I Any)
-> Int
-> Int
-> Ordering
loop SmallArray (DictAny Ord)
dicts SmallArray (I Any)
vx SmallArray (I Any)
vy Int
i Int
n
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = Ordering
EQ
      | Bool
otherwise =
          let d :: DictAny Ord
d = SmallArray (DictAny Ord) -> Int -> DictAny Ord
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (DictAny Ord)
dicts Int
i
              I Any
vx_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vx Int
i
              I Any
vy_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vy Int
i
              c :: Ordering
c = DictAny Ord -> Any -> Any -> Ordering
withDictOrd DictAny Ord
d Any
vx_i Any
vy_i
          in case Ordering
c of
               Ordering
EQ -> SmallArray (DictAny Ord)
-> SmallArray (I Any)
-> SmallArray (I Any)
-> Int
-> Int
-> Ordering
loop SmallArray (DictAny Ord)
dicts SmallArray (I Any)
vx SmallArray (I Any)
vy (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
n
               Ordering
_  -> Ordering
c

-- | Generic showsPrec using the 'Show' class.
gshowsPrec :: forall a. (Generic a, RepOf a ~ Rep I a, GInstances Show a) => Int -> a -> ShowS
gshowsPrec :: forall a.
(Generic a, RepOf a ~ Rep I a, GInstances Show a) =>
Int -> a -> ShowS
gshowsPrec Int
p a
x =
  let Rep Word
tx SmallArray (I Any)
vx = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
x
      dicts :: SmallArray (DictAny Show)
dicts = SmallArray (SmallArray (DictAny Show))
-> Int -> SmallArray (DictAny Show)
forall a. SmallArray a -> Int -> a
indexSmallArray (forall {k} (c :: * -> Constraint) (a :: k).
GInstances c a =>
SmallArray (SmallArray (DictAny c))
forall (c :: * -> Constraint) a.
GInstances c a =>
SmallArray (SmallArray (DictAny c))
gdicts @Show @a) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tx)
  in Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10 Bool -> Bool -> Bool
&& SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
vx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
       String -> ShowS
showString String
"Constructor " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> ShowS
forall a. Show a => a -> ShowS
shows Word
tx ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SmallArray (DictAny Show)
-> SmallArray (I Any) -> Int -> Int -> ShowS
loop SmallArray (DictAny Show)
dicts SmallArray (I Any)
vx Int
0 (SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
vx)
  where
    loop :: SmallArray (DictAny Show)
-> SmallArray (I Any) -> Int -> Int -> ShowS
loop SmallArray (DictAny Show)
dicts SmallArray (I Any)
vx Int
i Int
n
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = ShowS
forall a. a -> a
id
      | Bool
otherwise =
          let d :: DictAny Show
d = SmallArray (DictAny Show) -> Int -> DictAny Show
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (DictAny Show)
dicts Int
i
              I Any
vx_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vx Int
i
          in String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictAny Show -> Any -> Int -> ShowS
withDictShow DictAny Show
d Any
vx_i Int
11 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SmallArray (DictAny Show)
-> SmallArray (I Any) -> Int -> Int -> ShowS
loop SmallArray (DictAny Show)
dicts SmallArray (I Any)
vx (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
n

-- | Generic map over all fields.
gmap :: forall c a. (Generic a, RepOf a ~ Rep I a, GInstances c a) => (forall x. c x => x -> x) -> a -> a
gmap :: forall (c :: * -> Constraint) a.
(Generic a, RepOf a ~ Rep I a, GInstances c a) =>
(forall x. c x => x -> x) -> a -> a
gmap forall x. c x => x -> x
f a
x =
  let Rep Word
tx SmallArray (I Any)
vx = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
x
      dicts :: SmallArray (DictAny c)
dicts = SmallArray (SmallArray (DictAny c))
-> Int -> SmallArray (DictAny c)
forall a. SmallArray a -> Int -> a
indexSmallArray (forall {k} (c :: * -> Constraint) (a :: k).
GInstances c a =>
SmallArray (SmallArray (DictAny c))
forall (c :: * -> Constraint) a.
GInstances c a =>
SmallArray (SmallArray (DictAny c))
gdicts @c @a) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tx)
      n :: Int
n = SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
vx
      vx' :: SmallArray (I Any)
vx' = (forall s. ST s (SmallMutableArray s (I Any)))
-> SmallArray (I Any)
forall a. (forall s. ST s (SmallMutableArray s a)) -> SmallArray a
runSmallArray ((forall s. ST s (SmallMutableArray s (I Any)))
 -> SmallArray (I Any))
-> (forall s. ST s (SmallMutableArray s (I Any)))
-> SmallArray (I Any)
forall a b. (a -> b) -> a -> b
$ do
        m <- SmallArray (I Any)
-> Int
-> Int
-> ST s (SmallMutableArray (PrimState (ST s)) (I Any))
forall (m :: * -> *) a.
PrimMonad m =>
SmallArray a -> Int -> Int -> m (SmallMutableArray (PrimState m) a)
thawSmallArray SmallArray (I Any)
vx Int
0 Int
n
        let loop Int
i
              | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              | Bool
otherwise = do
                  let d :: DictAny c
d = SmallArray (DictAny c) -> Int -> DictAny c
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (DictAny c)
dicts Int
i
                  let I Any
vx_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vx Int
i
                  SmallMutableArray (PrimState (ST s)) (I Any)
-> Int -> I Any -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s (I Any)
SmallMutableArray (PrimState (ST s)) (I Any)
m Int
i (Any -> I Any
forall a. a -> I a
I (DictAny c -> (forall x. c x => x -> x) -> Any -> Any
forall (c :: * -> Constraint).
DictAny c -> (forall x. c x => x -> x) -> Any -> Any
withDictMap DictAny c
d x -> x
forall x. c x => x -> x
f Any
vx_i))
                  Int -> ST s ()
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        loop 0
        pure m
  in RepOf a -> a
forall a. Generic a => RepOf a -> a
to (Word -> SmallArray (I Any) -> Rep I a
forall {k} (f :: * -> *) (a :: k).
Word -> SmallArray (f Any) -> Rep f a
Rep Word
tx SmallArray (I Any)
vx')

-- | Generic foldMap over all fields.
gfoldMap :: forall c a m. (Generic a, RepOf a ~ Rep I a, GInstances c a, Monoid m) => (forall x. c x => x -> m) -> a -> m
gfoldMap :: forall (c :: * -> Constraint) a m.
(Generic a, RepOf a ~ Rep I a, GInstances c a, Monoid m) =>
(forall x. c x => x -> m) -> a -> m
gfoldMap forall x. c x => x -> m
f a
x =
  let Rep Word
tx SmallArray (I Any)
vx = a -> RepOf a
forall a. Generic a => a -> RepOf a
from a
x
      dicts :: SmallArray (DictAny c)
dicts = SmallArray (SmallArray (DictAny c))
-> Int -> SmallArray (DictAny c)
forall a. SmallArray a -> Int -> a
indexSmallArray (forall {k} (c :: * -> Constraint) (a :: k).
GInstances c a =>
SmallArray (SmallArray (DictAny c))
forall (c :: * -> Constraint) a.
GInstances c a =>
SmallArray (SmallArray (DictAny c))
gdicts @c @a) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tx)
  in SmallArray (DictAny c) -> SmallArray (I Any) -> Int -> Int -> m
loop SmallArray (DictAny c)
dicts SmallArray (I Any)
vx Int
0 (SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
vx)
  where
    loop :: SmallArray (DictAny c) -> SmallArray (I Any) -> Int -> Int -> m
loop SmallArray (DictAny c)
dicts SmallArray (I Any)
vx Int
i Int
n
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = m
forall a. Monoid a => a
mempty
      | Bool
otherwise =
          let d :: DictAny c
d = SmallArray (DictAny c) -> Int -> DictAny c
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (DictAny c)
dicts Int
i
              I Any
vx_i = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
vx Int
i
          in DictAny c -> (forall x. c x => x -> m) -> Any -> m
forall (c :: * -> Constraint) m.
DictAny c -> (forall x. c x => x -> m) -> Any -> m
withDictFoldMap DictAny c
d x -> m
forall x. c x => x -> m
f Any
vx_i m -> m -> m
forall a. Semigroup a => a -> a -> a
<> SmallArray (DictAny c) -> SmallArray (I Any) -> Int -> Int -> m
loop SmallArray (DictAny c)
dicts SmallArray (I Any)
vx (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
n

{-------------------------------------------------------------------------------
  Generic and GInstances for RowRep (§1.7 Generic instance layer)
-------------------------------------------------------------------------------}

-- | RowRep is an instance of Generic for product rows.
instance Generic (RowRep Identity ProductRowT r a) where
  type RepOf (RowRep Identity ProductRowT r a) = Rep I (RowRep Identity ProductRowT r a)
  from :: RowRep Identity 'ProductRowT r a
-> RepOf (RowRep Identity 'ProductRowT r a)
from (RowRep (Rep Word
t SmallArray (Identity Any)
v)) =
    let n :: Int
n = SmallArray (Identity Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (Identity Any)
v
        v' :: SmallArray (I Any)
v' = (forall s. ST s (SmallMutableArray s (I Any)))
-> SmallArray (I Any)
forall a. (forall s. ST s (SmallMutableArray s a)) -> SmallArray a
runSmallArray ((forall s. ST s (SmallMutableArray s (I Any)))
 -> SmallArray (I Any))
-> (forall s. ST s (SmallMutableArray s (I Any)))
-> SmallArray (I Any)
forall a b. (a -> b) -> a -> b
$ do
          m <- Int -> I Any -> ST s (SmallMutableArray (PrimState (ST s)) (I Any))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
n (String -> I Any
forall a. HasCallStack => String -> a
error String
"Polytropos.Generics.from: uninitialized")
          let loop Int
i
                | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                | Bool
otherwise = do
                    let Identity Any
val = SmallArray (Identity Any) -> Int -> Identity Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (Identity Any)
v Int
i
                    SmallMutableArray (PrimState (ST s)) (I Any)
-> Int -> I Any -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s (I Any)
SmallMutableArray (PrimState (ST s)) (I Any)
m Int
i (Any -> I Any
forall a. a -> I a
I Any
val)
                    Int -> ST s ()
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          loop 0
          pure m
    in Word
-> SmallArray (I Any) -> Rep I (RowRep Identity 'ProductRowT r a)
forall {k} (f :: * -> *) (a :: k).
Word -> SmallArray (f Any) -> Rep f a
Rep Word
t SmallArray (I Any)
v'
  to :: RepOf (RowRep Identity 'ProductRowT r a)
-> RowRep Identity 'ProductRowT r a
to (Rep Word
t SmallArray (I Any)
v) =
    let n :: Int
n = SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
v
        v' :: SmallArray (Identity Any)
v' = (forall s. ST s (SmallMutableArray s (Identity Any)))
-> SmallArray (Identity Any)
forall a. (forall s. ST s (SmallMutableArray s a)) -> SmallArray a
runSmallArray ((forall s. ST s (SmallMutableArray s (Identity Any)))
 -> SmallArray (Identity Any))
-> (forall s. ST s (SmallMutableArray s (Identity Any)))
-> SmallArray (Identity Any)
forall a b. (a -> b) -> a -> b
$ do
          m <- Int
-> Identity Any
-> ST s (SmallMutableArray (PrimState (ST s)) (Identity Any))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
n (String -> Identity Any
forall a. HasCallStack => String -> a
error String
"Polytropos.Generics.to: uninitialized")
          let loop Int
i
                | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                | Bool
otherwise = do
                    let I Any
val = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
v Int
i
                    SmallMutableArray (PrimState (ST s)) (Identity Any)
-> Int -> Identity Any -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s (Identity Any)
SmallMutableArray (PrimState (ST s)) (Identity Any)
m Int
i (Any -> Identity Any
forall a. a -> Identity a
Identity Any
val)
                    Int -> ST s ()
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          loop 0
          pure m
    in Rep Identity a -> RowRep Identity 'ProductRowT r a
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Word -> SmallArray (Identity Any) -> Rep Identity a
forall {k} (f :: * -> *) (a :: k).
Word -> SmallArray (f Any) -> Rep f a
Rep Word
t SmallArray (Identity Any)
v')

-- | RowRep is an instance of Generic for HKD product rows.
instance Generic (RowRep f ProductRowHKDT r a) where
  type RepOf (RowRep f ProductRowHKDT r a) = Rep I (RowRep f ProductRowHKDT r a)
  from :: RowRep f 'ProductRowHKDT r a
-> RepOf (RowRep f 'ProductRowHKDT r a)
from (RowRep (Rep Word
t SmallArray (f Any)
v)) =
    let n :: Int
n = SmallArray (f Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (f Any)
v
        v' :: SmallArray (I Any)
v' = (forall s. ST s (SmallMutableArray s (I Any)))
-> SmallArray (I Any)
forall a. (forall s. ST s (SmallMutableArray s a)) -> SmallArray a
runSmallArray ((forall s. ST s (SmallMutableArray s (I Any)))
 -> SmallArray (I Any))
-> (forall s. ST s (SmallMutableArray s (I Any)))
-> SmallArray (I Any)
forall a b. (a -> b) -> a -> b
$ do
          m <- Int -> I Any -> ST s (SmallMutableArray (PrimState (ST s)) (I Any))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
n (String -> I Any
forall a. HasCallStack => String -> a
error String
"Polytropos.Generics.fromHKD: uninitialized")
          let loop Int
i
                | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                | Bool
otherwise = do
                    let val :: f Any
val = SmallArray (f Any) -> Int -> f Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (f Any)
v Int
i
                    SmallMutableArray (PrimState (ST s)) (I Any)
-> Int -> I Any -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s (I Any)
SmallMutableArray (PrimState (ST s)) (I Any)
m Int
i (Any -> I Any
forall a. a -> I a
I (f Any -> Any
forall a b. a -> b
noInlineUnsafeCo f Any
val :: Any))
                    Int -> ST s ()
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          loop 0
          pure m
    in Word -> SmallArray (I Any) -> Rep I (RowRep f 'ProductRowHKDT r a)
forall {k} (f :: * -> *) (a :: k).
Word -> SmallArray (f Any) -> Rep f a
Rep Word
t SmallArray (I Any)
v'
  to :: RepOf (RowRep f 'ProductRowHKDT r a)
-> RowRep f 'ProductRowHKDT r a
to (Rep Word
t SmallArray (I Any)
v) =
    let n :: Int
n = SmallArray (I Any) -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray (I Any)
v
        v' :: SmallArray (f Any)
v' = (forall s. ST s (SmallMutableArray s (f Any)))
-> SmallArray (f Any)
forall a. (forall s. ST s (SmallMutableArray s a)) -> SmallArray a
runSmallArray ((forall s. ST s (SmallMutableArray s (f Any)))
 -> SmallArray (f Any))
-> (forall s. ST s (SmallMutableArray s (f Any)))
-> SmallArray (f Any)
forall a b. (a -> b) -> a -> b
$ do
          m <- Int -> f Any -> ST s (SmallMutableArray (PrimState (ST s)) (f Any))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
newSmallArray Int
n (String -> f Any
forall a. HasCallStack => String -> a
error String
"Polytropos.Generics.toHKD: uninitialized")
          let loop Int
i
                | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n = () -> ST s ()
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                | Bool
otherwise = do
                    let I Any
val = SmallArray (I Any) -> Int -> I Any
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray (I Any)
v Int
i
                    SmallMutableArray (PrimState (ST s)) (f Any)
-> Int -> f Any -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
writeSmallArray SmallMutableArray s (f Any)
SmallMutableArray (PrimState (ST s)) (f Any)
m Int
i (Any -> f Any
forall a b. a -> b
noInlineUnsafeCo Any
val :: f Any)
                    Int -> ST s ()
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          loop 0
          pure m
    in Rep f a -> RowRep f 'ProductRowHKDT r a
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Word -> SmallArray (f Any) -> Rep f a
forall {k} (f :: * -> *) (a :: k).
Word -> SmallArray (f Any) -> Rep f a
Rep Word
t SmallArray (f Any)
v')

-- | RowRep is an instance of Generic for sum rows.
instance Generic (RowRep f SumRowT s a) where
  type RepOf (RowRep f SumRowT s a) = Rep I (RowRep f SumRowT s a)
  from :: RowRep f 'SumRowT s a -> RepOf (RowRep f 'SumRowT s a)
from (RowRep Rep f a
r) = Rep f a -> Rep I (RowRep f 'SumRowT s a)
forall a b. a -> b
noInlineUnsafeCo Rep f a
r
  to :: RepOf (RowRep f 'SumRowT s a) -> RowRep f 'SumRowT s a
to RepOf (RowRep f 'SumRowT s a)
rep          = Rep f a -> RowRep f 'SumRowT s a
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Rep I (RowRep f 'SumRowT s a) -> Rep f a
forall a b. a -> b
noInlineUnsafeCo Rep I (RowRep f 'SumRowT s a)
RepOf (RowRep f 'SumRowT s a)
rep)

-- | RowRep is an instance of Generic for HKD sum rows.
instance Generic (RowRep f SumRowHKDT s a) where
  type RepOf (RowRep f SumRowHKDT s a) = Rep I (RowRep f SumRowHKDT s a)
  from :: RowRep f 'SumRowHKDT s a -> RepOf (RowRep f 'SumRowHKDT s a)
from (RowRep Rep f a
r) = Rep f a -> Rep I (RowRep f 'SumRowHKDT s a)
forall a b. a -> b
noInlineUnsafeCo Rep f a
r
  to :: RepOf (RowRep f 'SumRowHKDT s a) -> RowRep f 'SumRowHKDT s a
to RepOf (RowRep f 'SumRowHKDT s a)
rep          = Rep f a -> RowRep f 'SumRowHKDT s a
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Rep I (RowRep f 'SumRowHKDT s a) -> Rep f a
forall a b. a -> b
noInlineUnsafeCo Rep I (RowRep f 'SumRowHKDT s a)
RepOf (RowRep f 'SumRowHKDT s a)
rep)

-- | GInstances for ProductRowT derived from AllFields.
instance AllFields ProductRowT r c => GInstances c (RowRep Identity ProductRowT r a) where
  gdicts :: SmallArray (SmallArray (DictAny c))
gdicts = [SmallArray (DictAny c)] -> SmallArray (SmallArray (DictAny c))
forall a. [a] -> SmallArray a
smallArrayFromList [forall {k} (r :: RowType) (row :: k) (c :: * -> Constraint).
AllFields r row c =>
DictAllFields c
forall (r :: RowType) (row :: k1) (c :: * -> Constraint).
AllFields r row c =>
DictAllFields c
fieldDicts @ProductRowT @r @c]

-- | GInstances for ProductRowHKDT derived from AllFields.
instance AllFields ProductRowHKDT r c => GInstances c (RowRep f ProductRowHKDT r a) where
  gdicts :: SmallArray (SmallArray (DictAny c))
gdicts = [SmallArray (DictAny c)] -> SmallArray (SmallArray (DictAny c))
forall a. [a] -> SmallArray a
smallArrayFromList [forall {k} (r :: RowType) (row :: k) (c :: * -> Constraint).
AllFields r row c =>
DictAllFields c
forall (r :: RowType) (row :: k1) (c :: * -> Constraint).
AllFields r row c =>
DictAllFields c
fieldDicts @ProductRowHKDT @r @c]