-- |
-- Module : Data.Aeson.RecordAsTuple
-- Copyright : (c) Michael Ledger 2026
-- License : MPL-2.0
-- Maintainer : Michael Ledger <mike@quasimal.com>
module Data.Aeson.RecordAsTuple (
RecordAsTuple (..),
gtupleToJSON,
gtupleToEncoding,
gtupleParseJSON,
) where
import Control.Monad.ST.Strict (ST)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as JSON (Array, Encoding, FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withArray)
import Data.Aeson.Encoding.Internal (closeBracket, comma, emptyArray_, openBracket, (><))
import Data.Aeson.Types qualified as JSON (Parser)
import Data.Data (Proxy (..))
import Data.OpenApi (Definitions, NamedSchema (..), OpenApiItems (..), OpenApiType (..), Referenced (..), Schema (..), ToSchema (..))
import Data.OpenApi.Declare (Declare)
import Data.Primitive.Array (
MutableArray,
createArray,
writeArray,
)
import Data.String (fromString)
import Data.Typeable (Typeable, typeRep)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import GHC.Generics (
C1,
D1,
Generic (..),
K1 (K1),
M1 (M1),
S1,
type (:*:) (..),
)
import GHC.TypeNats (KnownNat, Nat, natVal, type (+))
-- | Use this with @-XDerivingVia@ to derive aeson decoders and encoders for
-- record types which encode the record as a JSON array rather than object.
--
-- Examples
-- >>> data P = P {x,y,z,w::Float} deriving stock (Show,Generic) deriving (ToJSON,FromJSON) via (RecordAsTuple P)
-- >>> JSON.toJSON (P 1 2 3 4)
-- Array [Number 1.0,Number 2.0,Number 3.0,Number 4.0]
-- >>> JSON.fromJSON @P (JSON.toJSON (P 1 2 3 4))
-- Success (P {x = 1.0, y = 2.0, z = 3.0, w = 4.0})
-- >>> data T = T {a,b,c::Float} deriving stock (Generic)
-- >>> JSON.toJSON (RecordAsTuple (T 1 2 3))
-- Array [Number 1.0,Number 2.0,Number 3.0]
newtype RecordAsTuple a = RecordAsTuple a
deriving stock (Eq, Ord, Show, Read)
instance
( Generic a
, Rep a ~ D1 _dt (C1 _mcons flds)
, GFieldsToJSON flds
, KnownNat (ProductSize flds)
)
=> ToJSON (RecordAsTuple a)
where
{-# INLINE toJSON #-}
{-# INLINE toEncoding #-}
toJSON (RecordAsTuple a) = JSON.Array (gtupleToJSON (from a))
toEncoding (RecordAsTuple a) = gtupleToEncoding (from a)
instance (Generic a, Rep a ~ D1 _dt (C1 _mcons flds), GFieldsFromJSON flds) => FromJSON (RecordAsTuple a) where
{-# INLINE parseJSON #-}
parseJSON v = RecordAsTuple . to <$> JSON.withArray "RecordAsTuple" gtupleParseJSON v
type family ProductSize flds :: Nat where
ProductSize (f :*: g) = ProductSize f + ProductSize g
ProductSize _ = 1
{-# INLINE recordSize #-}
{-# INLINE gtupleToJSON #-}
{-# INLINE gtupleToEncoding #-}
{-# INLINE gtupleParseJSON #-}
recordSize :: forall x. (KnownNat (ProductSize x)) => Int
recordSize = fromIntegral (natVal (Proxy @(ProductSize x)))
gtupleToJSON :: (KnownNat (ProductSize flds), GFieldsToJSON flds) => D1 _dt (C1 _mcons flds) k -> Vector JSON.Value
gtupleToJSON (M1 (M1 flds) :: D1 _ (C1 _ flds) _) =
Vector.fromArray
( createArray len (error "gtupleToJSON: unitialised element") \mut -> do
gunsafeWriteFieldsToJSON 0 mut flds
)
where
!len = recordSize @flds
gtupleToEncoding :: (KnownNat (ProductSize flds), GFieldsToJSON flds) => D1 _dt (C1 _mcons flds) k -> JSON.Encoding
gtupleToEncoding (M1 (M1 flds) :: D1 _ (C1 _ flds) _)
| len > 0 = openBracket >< gfieldsToEncoding flds >< closeBracket
| otherwise = emptyArray_
where
!len = recordSize @flds
gtupleParseJSON :: (GFieldsFromJSON flds) => JSON.Array -> JSON.Parser (D1 _dt (C1 _mcons flds) k)
gtupleParseJSON arr = M1 . M1 <$> gfieldsParseJSON 0 arr
class GFieldsToJSON a where
gunsafeWriteFieldsToJSON :: Int -> MutableArray s JSON.Value -> a k -> ST s ()
gfieldsToEncoding :: a k -> JSON.Encoding
class GFieldsFromJSON a where
gfieldsParseJSON :: Int -> JSON.Array -> JSON.Parser (a k)
instance (GFieldsToJSON f, GFieldsToJSON g, KnownNat (ProductSize f), KnownNat (ProductSize g)) => GFieldsToJSON (f :*: g) where
{-# INLINE gunsafeWriteFieldsToJSON #-}
{-# INLINE gfieldsToEncoding #-}
gunsafeWriteFieldsToJSON i mut (f :*: g) = do
gunsafeWriteFieldsToJSON i mut f
gunsafeWriteFieldsToJSON (i + alen) mut g
where
!alen = recordSize @f
gfieldsToEncoding (f :*: g) = gfieldsToEncoding f >< comma >< gfieldsToEncoding g
instance (GFieldsFromJSON f, GFieldsFromJSON g, KnownNat (ProductSize f), KnownNat (ProductSize g)) => GFieldsFromJSON (f :*: g) where
{-# INLINE gfieldsParseJSON #-}
gfieldsParseJSON i arr =
liftA2
(:*:)
(gfieldsParseJSON i arr)
(gfieldsParseJSON (i + alen) arr)
where
!alen = recordSize @f
instance (ToJSON a) => GFieldsToJSON (S1 _metasel (K1 _r a)) where
{-# INLINE gunsafeWriteFieldsToJSON #-}
{-# INLINE gfieldsToEncoding #-}
gunsafeWriteFieldsToJSON i mut (M1 (K1 x)) = writeArray mut i (JSON.toJSON x)
gfieldsToEncoding (M1 (K1 x)) = JSON.toEncoding x
instance (FromJSON a) => GFieldsFromJSON (S1 _metasel (K1 _r a)) where
{-# INLINE gfieldsParseJSON #-}
gfieldsParseJSON i arr = M1 . K1 <$> JSON.parseJSON (arr Vector.! i)
--------------------------------------------------------------------------------
-- openapi interop
-- | Gives the schema the name @show (typeRep @a _)@
instance
( Generic a
, Typeable a
, Rep a ~ D1 _dt (C1 _mcons flds)
, GFieldsToSchema flds
)
=> ToSchema (RecordAsTuple a)
where
declareNamedSchema _ = do
itemSchemas <- gfieldSchemas @flds
pure
( NamedSchema
(Just (fromString (show (typeRep (Proxy :: Proxy a)))))
mempty
{ _schemaType = Just OpenApiArray
, _schemaItems = Just (OpenApiItemsArray itemSchemas)
, _schemaMinItems = Just (fromIntegral (length itemSchemas))
, _schemaMaxItems = Just (fromIntegral (length itemSchemas))
}
)
class GFieldsToSchema a where
gfieldSchemas :: Declare (Definitions Schema) [Referenced Schema]
instance (GFieldsToSchema f, GFieldsToSchema g) => GFieldsToSchema (f :*: g) where
gfieldSchemas = liftA2 (<>) (gfieldSchemas @f) (gfieldSchemas @g)
instance (ToSchema a) => GFieldsToSchema (S1 _metasel (K1 _r a)) where
gfieldSchemas = do
NamedSchema _ s <- declareNamedSchema (Proxy @a)
pure [Inline s]