Objects.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Benchmarks.Data.Objects where

import Data.Aeson (ToJSON (..), Value)
import Data.Dynamic (Dynamic, Typeable, toDyn)
import Data.Proxy (Proxy (..))
import Data.String (fromString)

import Data.Aeson.Schema.Internal (Object (..), SchemaResult)
import Data.Aeson.Schema.Key (IsSchemaKey, SchemaKey, fromSchemaKey)
import Data.Aeson.Schema.Type (
  IsSchemaObjectMap,
  SchemaType,
  SchemaType' (..),
  ToSchemaObject,
 )
import Data.Aeson.Schema.Utils.All (All (..))
import qualified Data.Aeson.Schema.Utils.Compat as Compat

type MockSchema schema =
  ( MockSchemaResult (ToSchemaObject schema)
  , Object schema ~ SchemaResult (ToSchemaObject schema)
  , ToJSON (Object schema)
  )

schemaObject :: forall schema. (MockSchema schema) => Object schema
schemaObject = schemaResult (Proxy @(ToSchemaObject schema))

schemaValue :: forall schema. (MockSchema schema) => Value
schemaValue = toJSON $ schemaObject @schema

class (Typeable (SchemaResult schema)) => MockSchemaResult (schema :: SchemaType) where
  schemaResult :: Proxy schema -> SchemaResult schema

instance MockSchemaResult ('SchemaScalar Int) where
  schemaResult _ = 42

instance
  ( All MockSchemaResultPair pairs
  , IsSchemaObjectMap pairs
  , Typeable pairs
  ) =>
  MockSchemaResult ('SchemaObject pairs)
  where
  schemaResult _ = UnsafeObject $ Compat.fromList $ mapAll @MockSchemaResultPair @pairs schemaResultPair

class MockSchemaResultPair (pair :: (SchemaKey, SchemaType)) where
  schemaResultPair :: Proxy pair -> (Compat.Key, Dynamic)

instance (IsSchemaKey key, MockSchemaResult inner) => MockSchemaResultPair '(key, inner) where
  schemaResultPair _ = (fromString $ fromSchemaKey @key, toDyn $ schemaResult $ Proxy @inner)