{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{-|
Module      : Polytropos.Aeson
Description : aeson JSON codecs for Polytropos open records and variants
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)

Linear \(O(N)\) 'A.ToJSON' and 'A.FromJSON' instances for heterogeneous and
homogeneous 'Record' and 'Variant' types without standard "GHC.Generics"
compile slowdowns: the codecs unroll the flat @Rep@ payload directly into
a JSON object and back, with no generic-representation tree anywhere.

= Architectural Overview & Rationale

== Encoding Structure

* A record encodes as an anonymous JSON object with one key per field symbol, in row order.
* A variant encodes as a single-member tagged object @{"ctor": fields}@, where the
  member key is the active constructor symbol and the value is the JSON object of that
  constructor's payload fields (or empty object for a nullary constructor).

== Truly Heterogeneous Row Support

Unlike satellites restricted to homogeneous types, @polytropos-aeson@ provides genuine
heterogeneous serialization across open rows via 'AllToJSON' and 'AllFromJSON':
every field requires 'A.ToJSON' \/ 'A.FromJSON' at /its own concrete type/, so rows
mixing 'String', 'Int', 'Bool', custom types, or nested rows serialize and deserialize
directly without nominal intermediate wrappers.

== Why Avoid GHC.Generics Trees for JSON

Standard @aeson@ deriving walks a nested binary tree of @M1@, @(:*:)@, and @(:+:)@ constructors.
On large schemas (30+ fields or constructors), this causes significant compile-time memory
blow-up and runtime intermediate allocation overhead. @polytropos-aeson@ walks the flat array of
payload slots in a single tight loop directly into @aeson@'s 'Data.Aeson.KeyMap.KeyMap'.

= When to Use This Module

* When serializing or deserializing @polytropos@ open records and variants to and from JSON.

= Worked Example

Records are most conveniently constructed using the @REC { ... }@ syntax enabled
by the @polytropos@ source plugin (via @-fplugin=Polytropos.Plugin@):

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE TypeApplications #-}
> {-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}
>
> import Data.Aeson (encode, decode)
> import Polytropos
> import Polytropos.Aeson
>
> -- A genuinely heterogeneous record mixing String, Int, and Bool:
> type Config = Record '["host" ':= String, "port" ':= Int, "active" ':= Bool]
>
> cfg :: Config
> cfg = REC { host = "localhost", port = 8080, active = True }
>
> -- Encodes to JSON: {"active":true,"host":"localhost","port":8080}
> jsonBytes = encode cfg
>
> -- Decodes back to Config:
> Just cfg' = decode @Config jsonBytes

Variants with heterogeneous constructors serialize into single-member tagged objects:

> type Response = Variant '["Ok" ':= '["body" ':= String, "status" ':= Int], "Err" ':= '["reason" ':= String]]
>
> resp :: Response
> resp = VAR { Ok = REC { body = "server ready", status = 200 } }
>
> -- Encodes to JSON: {"Ok":{"body":"server ready","status":200}}
> respBytes = encode resp
-}
module Polytropos.Aeson
  ( -- * Heterogeneous Row Codecs
    AllToJSON (..)
  , AllFromJSON (..)
  , AllCtorsToJSON (..)
  , AllCtorsFromJSON (..)

    -- * Homogeneity Evidence and Row Introspection
    -- $homogeneity
  , AllFieldsAre
  , AllCtorsHom (..)
  , FieldNames (..)
  , RowField
  , SumField
  ) where

import Data.Functor.Identity (Identity (..))
import Data.Kind             (Constraint, Type)
import Data.Proxy            (Proxy (..))
import Data.Void             (Void)
import qualified Data.Text as T
import GHC.Exts              (Any, toList)
import GHC.TypeLits          (KnownSymbol, symbolVal)
import qualified Data.Aeson        as A
import qualified Data.Aeson.Types  as AT
import qualified Data.Aeson.Key    as K
import qualified Data.Aeson.KeyMap as KM
import Polytropos            (Record, Variant)
import Polytropos.Core       (Pair (..), Row, SumRow, RowRep (..), noInlineUnsafeCo,
                              productRep, injectRep, repTag, repVals)

{-------------------------------------------------------------------------------
  Heterogeneous row constraint walks
-------------------------------------------------------------------------------}

-- | Evidence that every field of the row @r@ has a 'A.ToJSON' instance
-- at that field's own type. Serializes the erased payload slots in row order.
class AllToJSON (r :: Row) where
  encRecordFields :: Proxy r -> [Identity Any] -> [(K.Key, A.Value)]

instance AllToJSON '[] where
  encRecordFields :: Proxy '[] -> [Identity Any] -> [(Key, Value)]
encRecordFields Proxy '[]
_ [Identity Any]
_ = []

instance (KnownSymbol n, A.ToJSON a, AllToJSON r) => AllToJSON ((n ':= a) ': r) where
  encRecordFields :: Proxy ((n ':= a) : r) -> [Identity Any] -> [(Key, Value)]
encRecordFields Proxy ((n ':= a) : r)
_ (Identity Any
x : [Identity Any]
xs) =
    (Text -> Key
K.fromText (String -> Text
T.pack (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))), a -> Value
forall a. ToJSON a => a -> Value
A.toJSON (Any -> a
forall a b. a -> b
noInlineUnsafeCo Any
x :: a))
    (Key, Value) -> [(Key, Value)] -> [(Key, Value)]
forall a. a -> [a] -> [a]
: Proxy r -> [Identity Any] -> [(Key, Value)]
forall (r :: Row).
AllToJSON r =>
Proxy r -> [Identity Any] -> [(Key, Value)]
encRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) [Identity Any]
xs
  encRecordFields Proxy ((n ':= a) : r)
_ [] = String -> [(Key, Value)]
forall a. HasCallStack => String -> a
error String
"polytropos-aeson: payload arity mismatch"

-- | Evidence that every field of the row @r@ has a 'A.FromJSON' instance
-- at that field's own type. Decodes each field by name from the JSON object.
class AllFromJSON (r :: Row) where
  decRecordFields :: Proxy r -> A.Object -> AT.Parser [Identity Any]

instance AllFromJSON '[] where
  decRecordFields :: Proxy '[] -> Object -> Parser [Identity Any]
decRecordFields Proxy '[]
_ Object
_ = [Identity Any] -> Parser [Identity Any]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (KnownSymbol n, A.FromJSON a, AllFromJSON r) => AllFromJSON ((n ':= a) ': r) where
  decRecordFields :: Proxy ((n ':= a) : r) -> Object -> Parser [Identity Any]
decRecordFields Proxy ((n ':= a) : r)
_ Object
obj = do
    v <- Object
obj Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
A..: Text -> Key
K.fromText (String -> Text
T.pack (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))) :: AT.Parser a
    vs <- decRecordFields (Proxy @r) obj
    pure (Identity (noInlineUnsafeCo v :: Any) : vs)

-- | Evidence that every constructor of the sum row @s@ has a heterogeneous
-- field row satisfying 'AllToJSON', paired with its constructor tag index.
class AllCtorsToJSON (s :: SumRow) where
  encVariantTag :: Proxy s -> Word -> [Identity Any] -> A.Value

instance AllCtorsToJSON '[] where
  encVariantTag :: Proxy '[] -> Word -> [Identity Any] -> Value
encVariantTag Proxy '[]
_ Word
_ [Identity Any]
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"polytropos-aeson: empty variant has no constructors"

instance (KnownSymbol c, AllToJSON fs, AllCtorsToJSON s)
      => AllCtorsToJSON ((c ':= fs) ': s) where
  encVariantTag :: Proxy ((c ':= fs) : s) -> Word -> [Identity Any] -> Value
encVariantTag Proxy ((c ':= fs) : s)
_ Word
0 [Identity Any]
slots =
    let cName :: String
cName = Proxy c -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @c)
        fields :: Object
fields = [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList (Proxy fs -> [Identity Any] -> [(Key, Value)]
forall (r :: Row).
AllToJSON r =>
Proxy r -> [Identity Any] -> [(Key, Value)]
encRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @fs) [Identity Any]
slots)
    in Object -> Value
A.Object (Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton (Text -> Key
K.fromText (String -> Text
T.pack String
cName)) (Object -> Value
A.Object Object
fields))
  encVariantTag Proxy ((c ':= fs) : s)
_ Word
tag [Identity Any]
slots =
    Proxy s -> Word -> [Identity Any] -> Value
forall (s :: SumRow).
AllCtorsToJSON s =>
Proxy s -> Word -> [Identity Any] -> Value
encVariantTag (forall (t :: SumRow). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) (Word
tag Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1) [Identity Any]
slots

-- | Evidence that every constructor of the sum row @s@ has a heterogeneous
-- field row satisfying 'AllFromJSON', paired with its constructor tag index.
class AllCtorsFromJSON (s :: SumRow) where
  decVariantVal :: Proxy s -> Word -> T.Text -> A.Value -> AT.Parser (Word, [Identity Any])

instance AllCtorsFromJSON '[] where
  decVariantVal :: Proxy '[] -> Word -> Text -> Value -> Parser (Word, [Identity Any])
decVariantVal Proxy '[]
_ Word
_ Text
_ Value
_ = String -> Parser (Word, [Identity Any])
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"polytropos-aeson: unknown constructor"

instance (KnownSymbol c, AllFromJSON fs, AllCtorsFromJSON s)
      => AllCtorsFromJSON ((c ':= fs) ': s) where
  decVariantVal :: Proxy ((c ':= fs) : s)
-> Word -> Text -> Value -> Parser (Word, [Identity Any])
decVariantVal Proxy ((c ':= fs) : s)
_ Word
idx Text
cKey Value
val
    | Text
cKey Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack (Proxy c -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @c)) = case Value
val of
        A.Object Object
o -> do
          slots <- Proxy fs -> Object -> Parser [Identity Any]
forall (r :: Row).
AllFromJSON r =>
Proxy r -> Object -> Parser [Identity Any]
decRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @fs) Object
o
          pure (idx, slots)
        Value
_ -> String -> Parser (Word, [Identity Any])
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"polytropos-aeson: expected an object of constructor fields"
    | Bool
otherwise =
        Proxy s -> Word -> Text -> Value -> Parser (Word, [Identity Any])
forall (s :: SumRow).
AllCtorsFromJSON s =>
Proxy s -> Word -> Text -> Value -> Parser (Word, [Identity Any])
decVariantVal (forall (t :: SumRow). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) (Word
idx Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) Text
cKey Value
val

{-------------------------------------------------------------------------------
  Record codecs
-------------------------------------------------------------------------------}

instance AllToJSON r => A.ToJSON (Record r) where
  toJSON :: Record r -> Value
toJSON (RowRep Rep Identity ()
rep) =
    Object -> Value
A.Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList (Proxy r -> [Identity Any] -> [(Key, Value)]
forall (r :: Row).
AllToJSON r =>
Proxy r -> [Identity Any] -> [(Key, Value)]
encRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) (SmallArray (Identity Any) -> [Item (SmallArray (Identity Any))]
forall l. IsList l => l -> [Item l]
toList (Rep Identity () -> SmallArray (Identity Any)
forall {k} (f :: * -> *) (a :: k). Rep f a -> SmallArray (f Any)
repVals Rep Identity ()
rep))))
  toJSONList :: [Record r] -> Value
toJSONList [Record r]
xs = (Record r -> Value) -> [Record r] -> Value
forall a. (a -> Value) -> [a] -> Value
AT.listValue Record r -> Value
forall a. ToJSON a => a -> Value
A.toJSON [Record r]
xs
  toEncoding :: Record r -> Encoding
toEncoding (RowRep Rep Identity ()
rep) =
    Value -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding (Object -> Value
A.Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList (Proxy r -> [Identity Any] -> [(Key, Value)]
forall (r :: Row).
AllToJSON r =>
Proxy r -> [Identity Any] -> [(Key, Value)]
encRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) (SmallArray (Identity Any) -> [Item (SmallArray (Identity Any))]
forall l. IsList l => l -> [Item l]
toList (Rep Identity () -> SmallArray (Identity Any)
forall {k} (f :: * -> *) (a :: k). Rep f a -> SmallArray (f Any)
repVals Rep Identity ()
rep)))))
  toEncodingList :: [Record r] -> Encoding
toEncodingList [Record r]
xs = (Record r -> Encoding) -> [Record r] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
AT.listEncoding Record r -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding [Record r]
xs
  omitField :: Record r -> Bool
omitField Record r
_ = Bool
False

instance AllFromJSON r => A.FromJSON (Record r) where
  parseJSON :: Value -> Parser (Record r)
parseJSON = String
-> (Object -> Parser (Record r)) -> Value -> Parser (Record r)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Record" ((Object -> Parser (Record r)) -> Value -> Parser (Record r))
-> (Object -> Parser (Record r)) -> Value -> Parser (Record r)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    vs <- Proxy r -> Object -> Parser [Identity Any]
forall (r :: Row).
AllFromJSON r =>
Proxy r -> Object -> Parser [Identity Any]
decRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) Object
obj
    pure (RowRep (productRep vs))
  parseJSONList :: Value -> Parser [Record r]
parseJSONList Value
v = case Value
v of
    AT.Array Array
vals -> (Value -> Parser (Record r)) -> [Value] -> Parser [Record r]
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 (String
-> (Object -> Parser (Record r)) -> Value -> Parser (Record r)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Record" (\Object
o -> Rep Identity () -> Record r
forall {k} k1 (f :: * -> *) (r :: RowType) (row :: k1) (a :: k).
Rep f a -> RowRep f r row a
RowRep (Rep Identity () -> Record r)
-> ([Identity Any] -> Rep Identity ())
-> [Identity Any]
-> Record 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] -> Record r)
-> Parser [Identity Any] -> Parser (Record r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy r -> Object -> Parser [Identity Any]
forall (r :: Row).
AllFromJSON r =>
Proxy r -> Object -> Parser [Identity Any]
decRecordFields (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r) Object
o)) (Array -> [Item Array]
forall l. IsList l => l -> [Item l]
toList Array
vals)
    Value
_             -> String -> Parser [Record r]
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"polytropos-aeson: expected an array of records"
  omittedField :: Maybe (Record r)
omittedField = Maybe (Record r)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Variant codecs
-------------------------------------------------------------------------------}

instance AllCtorsToJSON s => A.ToJSON (Variant s) where
  toJSON :: Variant s -> Value
toJSON (RowRep Rep Identity ()
rep) = Proxy s -> Word -> [Identity Any] -> Value
forall (s :: SumRow).
AllCtorsToJSON s =>
Proxy s -> Word -> [Identity Any] -> Value
encVariantTag (forall (t :: SumRow). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) (Rep Identity () -> Word
forall {k} (f :: * -> *) (a :: k). Rep f a -> Word
repTag Rep Identity ()
rep) (SmallArray (Identity Any) -> [Item (SmallArray (Identity Any))]
forall l. IsList l => l -> [Item l]
toList (Rep Identity () -> SmallArray (Identity Any)
forall {k} (f :: * -> *) (a :: k). Rep f a -> SmallArray (f Any)
repVals Rep Identity ()
rep))
  toJSONList :: [Variant s] -> Value
toJSONList [Variant s]
xs = (Variant s -> Value) -> [Variant s] -> Value
forall a. (a -> Value) -> [a] -> Value
AT.listValue Variant s -> Value
forall a. ToJSON a => a -> Value
A.toJSON [Variant s]
xs
  toEncoding :: Variant s -> Encoding
toEncoding Variant s
v = Value -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding (Variant s -> Value
forall a. ToJSON a => a -> Value
A.toJSON Variant s
v)
  toEncodingList :: [Variant s] -> Encoding
toEncodingList [Variant s]
xs = (Variant s -> Encoding) -> [Variant s] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
AT.listEncoding Variant s -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding [Variant s]
xs
  omitField :: Variant s -> Bool
omitField Variant s
_ = Bool
False

instance AllCtorsFromJSON s => A.FromJSON (Variant s) where
  parseJSON :: Value -> Parser (Variant s)
parseJSON = String
-> (Object -> Parser (Variant s)) -> Value -> Parser (Variant s)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Variant" ((Object -> Parser (Variant s)) -> Value -> Parser (Variant s))
-> (Object -> Parser (Variant s)) -> Value -> Parser (Variant s)
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
    case Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
obj of
      [(Key
k, Value
v)] -> do
        (idx, slots) <- Proxy s -> Word -> Text -> Value -> Parser (Word, [Identity Any])
forall (s :: SumRow).
AllCtorsFromJSON s =>
Proxy s -> Word -> Text -> Value -> Parser (Word, [Identity Any])
decVariantVal (forall (t :: SumRow). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) Word
0 (Key -> Text
K.toText Key
k) Value
v
        pure (RowRep (injectRep (fromIntegral idx) slots))
      [(Key, Value)]
_ -> String -> Parser (Variant s)
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"polytropos-aeson: expected a single-member object"
  parseJSONList :: Value -> Parser [Variant s]
parseJSONList Value
v = case Value
v of
    AT.Array Array
vals -> (Value -> Parser (Variant s)) -> [Value] -> Parser [Variant s]
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 (String
-> (Object -> Parser (Variant s)) -> Value -> Parser (Variant s)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Variant" ((Object -> Parser (Variant s)) -> Value -> Parser (Variant s))
-> (Object -> Parser (Variant s)) -> Value -> Parser (Variant s)
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      case Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
obj of
        [(Key
k, Value
val)] -> do
          (idx, slots) <- Proxy s -> Word -> Text -> Value -> Parser (Word, [Identity Any])
forall (s :: SumRow).
AllCtorsFromJSON s =>
Proxy s -> Word -> Text -> Value -> Parser (Word, [Identity Any])
decVariantVal (forall (t :: SumRow). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s) Word
0 (Key -> Text
K.toText Key
k) Value
val
          pure (RowRep (injectRep (fromIntegral idx) slots))
        [(Key, Value)]
_ -> String -> Parser (Variant s)
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"polytropos-aeson: expected a single-member object") (Array -> [Item Array]
forall l. IsList l => l -> [Item l]
toList Array
vals)
    Value
_             -> String -> Parser [Variant s]
forall a. HasCallStack => String -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"polytropos-aeson: expected an array of variants"
  omittedField :: Maybe (Variant s)
omittedField = Maybe (Variant s)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Homogeneity evidence and row introspection (Reflection helpers)
-------------------------------------------------------------------------------}

-- $homogeneity
--
-- === Homogeneity Evidence and Introspection Helpers
--
-- In addition to the primary heterogeneous codecs ('AllToJSON', 'AllFromJSON'),
-- this module provides closed type families and reflection classes for
-- inspecting row metadata and enforcing uniform payload types.
--
-- 1. 'AllFieldsAre' is a closed type family asserting that /every/ field in a row
--    has the uniform type @a@.
-- 2. 'RowField' and 'SumField' compute the uniform payload type directly from
--    the row or sum row, eliminating type ambiguity for custom instances.
-- 3. 'FieldNames' reifies type-level 'GHC.TypeLits.Symbol' field labels into
--    runtime @['String']@ keys in exact row order.
-- 4. 'AllCtorsHom' reifies the constructor topology of a homogeneous sum row into
--    @[(String, [String])]@ (mapping each constructor name to its list of field names).

-- | Evidence that every field of the row @r@ has type @a@.
type family AllFieldsAre (a :: Type) (r :: Row) :: Constraint where
  AllFieldsAre _  '[]                = ()
  AllFieldsAre a ((n ':= a) ': rest) = AllFieldsAre a rest

-- | Extracts the uniform field type of a homogeneous row: the type of /every/
-- field, or 'Void' for the empty row @'[]@.
type family RowField (r :: Row) :: Type where
  RowField '[]                 = Void
  RowField ((n ':= a) ': rest) = a

-- | Extracts the uniform field type shared by every constructor of a homogeneous
-- sum row, or 'Void' for the empty sum @'[]@.
type family SumField (s :: SumRow) :: Type where
  SumField '[]                = Void
  SumField ((c ':= fs) ': s)  = RowField fs

-- | The field names of a row, in exact row order, reified from type-level
-- 'GHC.TypeLits.Symbol' labels into runtime @['String']@ keys.
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)

-- | Reflection dictionary for homogeneous sum rows (variants).
--
-- Reifies the full constructor topology into a runtime list pairing each
-- constructor symbol with its ordered field symbols: @[(String, [String])]@.
class AllCtorsHom (a :: Type) (s :: SumRow) where
  ctorSpecs :: Proxy a -> Proxy s -> [(String, [String])]

instance AllCtorsHom a '[] where
  ctorSpecs :: Proxy a -> Proxy '[] -> [(String, [String])]
ctorSpecs Proxy a
_ Proxy '[]
_ = []

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