-- |
-- Module : Data.Aeson.RecordAsTuple
-- Copyright : (c) Michael Ledger 2026
-- License : MPL-2.0
-- Maintainer : Michael Ledger <mike@quasimal.com>
module Data.Aeson.RecordAsTuple (RecordAsTuple (..)) 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 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 -> JSON.Array
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]