aeson-openapi-record-as-tuple (empty) → 0.1.0.0
raw patch · 4 files changed
+309/−0 lines, 4 filesdep +QuickCheckdep +aesondep +aeson-openapi-record-as-tuple
Dependencies added: QuickCheck, aeson, aeson-openapi-record-as-tuple, base, bytestring, generic-random, hspec, openapi3, primitive, vector
Files
- CHANGELOG +3/−0
- aeson-openapi-record-as-tuple.cabal +92/−0
- src/Data/Aeson/RecordAsTuple.hs +169/−0
- tests/spec.hs +45/−0
+ CHANGELOG view
@@ -0,0 +1,3 @@+0.1.0.0 - 2026-01-28 Wed+========================+Initial release
+ aeson-openapi-record-as-tuple.cabal view
@@ -0,0 +1,92 @@+cabal-version: 2.4+name: aeson-openapi-record-as-tuple+version: 0.1.0.0+build-type: Simple+license: MPL-2.0+author: Michael Ledger+maintainer: mike@quasimal.com+category: Default+synopsis: Encode and decode Haskell records as JSON tuples+description: This package lets you derive ToJSON/FromJSON instances for record data-types that are encoded into tuples+extra-doc-files:+ CHANGELOG++source-repository head+ type: git+ location: https://gitlab.com/_mike/aeson-record-as-tuple++library+ build-depends:+ aeson >=1.0.0.0 && <2.3,+ base >=4.16 && <5,+ openapi3 >=3 && <4,+ primitive >=0.7.3.0,+ vector >=0.12.2.0,++ hs-source-dirs: src+ exposed-modules:+ Data.Aeson.RecordAsTuple++ ghc-options:+ -Wall+ -Wno-partial-type-signatures++ default-language: GHC2021+ default-extensions:+ AllowAmbiguousTypes+ BangPatterns+ BlockArguments+ DataKinds+ DerivingStrategies+ DerivingVia+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ ImportQualifiedPost+ OverloadedStrings+ PartialTypeSignatures+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ TypeSynonymInstances+ UndecidableInstances++test-suite aeson-record-as-tuple-tests+ type: exitcode-stdio-1.0+ main-is: spec.hs+ hs-source-dirs: tests+ build-depends:+ QuickCheck,+ aeson,+ aeson-openapi-record-as-tuple,+ base,+ bytestring,+ generic-random,+ hspec,++ ghc-options:+ -Wall+ -Wno-partial-type-signatures++ default-language: GHC2021+ default-extensions:+ AllowAmbiguousTypes+ BangPatterns+ BlockArguments+ DataKinds+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ ImportQualifiedPost+ OverloadedStrings+ PartialTypeSignatures+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ TypeSynonymInstances+ UndecidableInstances
+ src/Data/Aeson/RecordAsTuple.hs view
@@ -0,0 +1,169 @@+-- |+-- 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]
+ tests/spec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NoFieldSelectors #-}++import Data.Aeson qualified as JSON+import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generic)+import Data.Aeson.RecordAsTuple+import Data.ByteString.Builder qualified as Builder+import Generic.Random.DerivingVia (GenericArbitraryU (..))+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (Arbitrary (..))++main :: IO ()+main = hspec spec++spec :: Spec+spec =+ describe "roundtrips" do+ prop "example via toJSON" prop_concocted+ prop "example via toEncoding" prop_concocted_toEncoding++prop_concocted :: A -> Bool+prop_concocted a =+ JSON.fromJSON (JSON.toJSON a) == JSON.Success a++prop_concocted_toEncoding :: A -> Bool+prop_concocted_toEncoding a =+ JSON.decode enc == Just a+ where+ enc = Builder.toLazyByteString (JSON.fromEncoding (JSON.toEncoding a))++data A = A {a, b, c, d :: Maybe B}+ deriving stock (Eq, Ord, Show, Generic)+ deriving (Arbitrary) via (GenericArbitraryU A)+ deriving (ToJSON, FromJSON) via (RecordAsTuple A)++data B = B {a, b, c, d :: Maybe C}+ deriving stock (Eq, Ord, Show, Generic)+ deriving (Arbitrary) via (GenericArbitraryU B)+ deriving (ToJSON, FromJSON) via (RecordAsTuple B)++data C = C {x, y, z, w, a, b, c, d :: Maybe Int}+ deriving stock (Eq, Ord, Show, Generic)+ deriving (Arbitrary) via (GenericArbitraryU C)+ deriving (ToJSON, FromJSON) via (RecordAsTuple C)