{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module:      Data.JSON.ToJSONSchema
-- Copyright:   (c) DPella AB 2025
-- License:     LicenseRef-AllRightsReserved
-- Maintainer:  <matti@dpella.io>, <lobo@dpella.io>
--
-- Core machinery for deriving JSON Schema definitions from Haskell types.
--
-- This module provides a type class and generic implementation for
-- automatically deriving JSON Schema descriptions from Haskell data types.
-- The generated schemas follow the JSON Schema 2020-12 specification.
--
-- = Usage
--
-- Define instances using the default generic implementation:
--
-- @
-- data Person = Person
--   { name :: Text
--   , age :: Int
--   } deriving (Generic)
--
-- instance ToJSONSchema Person
-- @
--
-- Or provide custom instances for more control:
--
-- @
-- instance ToJSONSchema UUID where
--   toJSONSchema _ = object
--     [ "type" .= ("string" :: Text)
--     , "minLength" .= 36
--     , "maxLength" .= 36
--     ]
-- @
module Data.JSON.ToJSONSchema (
  ToJSONSchema (..),
  Proxy (..),
) where

import Data.Aeson
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Maybe (isJust)
import Data.Proxy
import Data.String (IsString (..))
import Data.Text (Text, pack)
import Data.Typeable
import Data.Vector qualified as V
import GHC.Generics
import GHC.TypeLits

-- | Type class for converting Haskell types to JSON Schema.
--
-- The class provides a default implementation using GHC generics,
-- which works for most algebraic data types. Custom instances can
-- be defined for types requiring special schema representations.
class ToJSONSchema a where
  -- | Generate a JSON Schema for the given type.
  --
  -- The Proxy argument carries the type information without
  -- requiring an actual value of that type.
  --
  -- >>> toJSONSchema (Proxy :: Proxy Bool)
  -- {"type": "boolean"}
  toJSONSchema :: Proxy a -> Value
  default toJSONSchema
    :: ( Generic a
       , GToJSONSchema (Rep a)
       , Typeable a
       )
    => Proxy a
    -> Value
  -- We start with no root name; the D1 instance will set the root name
  -- and wrap the result with $defs and a top-level $ref. This allows
  -- recursive types to refer to themselves using $ref without infinite recursion.
  toJSONSchema Proxy a
_ = forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema @(Rep a) Bool
False Maybe Text
forall a. Maybe a
Nothing (Proxy (Rep a a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep a a))

-- | String instance with overlapping to handle String as a special case, and not as [Char]
instance {-# OVERLAPPING #-} ToJSONSchema String where
  toJSONSchema :: Proxy String -> Value
toJSONSchema Proxy String
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"string" :: Text)]

-- | Text instance.
instance ToJSONSchema Text where
  toJSONSchema :: Proxy Text -> Value
toJSONSchema Proxy Text
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"string" :: Text)]

-- | Boolean schema instance.
instance ToJSONSchema Bool where
  toJSONSchema :: Proxy Bool -> Value
toJSONSchema Proxy Bool
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"boolean" :: Text)]

-- | Machine integer schema instance.
instance ToJSONSchema Int where
  toJSONSchema :: Proxy Int -> Value
toJSONSchema Proxy Int
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"integer" :: Text)]

-- | Arbitrary precision integer schema instance.
instance ToJSONSchema Integer where
  toJSONSchema :: Proxy Integer -> Value
toJSONSchema Proxy Integer
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"integer" :: Text)]

-- | Single precision floating point schema instance.
instance ToJSONSchema Float where
  toJSONSchema :: Proxy Float -> Value
toJSONSchema Proxy Float
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"number" :: Text)]

-- | Double precision floating point schema instance.
instance ToJSONSchema Double where
  toJSONSchema :: Proxy Double -> Value
toJSONSchema Proxy Double
_ = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"number" :: Text)]

-- | List schema instance for homogeneous arrays.
instance (ToJSONSchema a) => ToJSONSchema [a] where
  toJSONSchema :: Proxy [a] -> Value
toJSONSchema Proxy [a]
_ =
    [Pair] -> Value
object
      [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"array" :: Text)
      , Key
"items" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Proxy a -> Value
forall a. ToJSONSchema a => Proxy a -> Value
toJSONSchema (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
      ]

-- | Either schema instance for tagged unions.
--
-- Encodes as Aeson's default representation with Left/Right tags:
-- @
-- Left x  -> {\"Left\": x}
-- Right y -> {\"Right\": y}
-- @
instance (ToJSONSchema a, ToJSONSchema b) => ToJSONSchema (Either a b) where
  toJSONSchema :: Proxy (Either a b) -> Value
toJSONSchema Proxy (Either a b)
_ =
    [Pair] -> Value
object
      [ Key
"anyOf"
          Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object
                [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
                , Key
"properties"
                    Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                      [ Key
"Left" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Proxy a -> Value
forall a. ToJSONSchema a => Proxy a -> Value
toJSONSchema (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
                      ]
                , Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([ Text
"Left" ] :: [Text])
                , Key
"additionalProperties" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
                ]
             , [Pair] -> Value
object
                [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
                , Key
"properties"
                    Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                      [ Key
"Right" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Proxy b -> Value
forall a. ToJSONSchema a => Proxy a -> Value
toJSONSchema (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
                      ]
                , Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([ Text
"Right" ] :: [Text])
                , Key
"additionalProperties" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
                ]
             ]
      ]

-- | Maybe schema instance allowing null values.
--
-- A Maybe value can be either the wrapped type or null:
-- @
-- Just x  -> x
-- Nothing -> null
-- @
instance (ToJSONSchema a) => ToJSONSchema (Maybe a) where
  toJSONSchema :: Proxy (Maybe a) -> Value
toJSONSchema Proxy (Maybe a)
_ =
    [Pair] -> Value
object
      [ Key
"anyOf"
          Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ Proxy a -> Value
forall a. ToJSONSchema a => Proxy a -> Value
toJSONSchema (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
             , [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"null" :: Text)]
             ]
      ]

-- | Generic type class for deriving JSON schemas.
--
-- This class handles the generic representation of data types
-- and converts them to appropriate JSON Schema structures.
--
-- The Bool parameter indicates whether we're inside a sum type
-- that needs tagging for proper deserialization.
class GToJSONSchema f where
  -- | Generate schema from generic representation.
  --
  -- The Bool parameter controls tagged union representation:
  -- * True: Add "tag" field for sum type constructors
  -- * False: No tagging needed
  -- The Maybe Text carries the root datatype name, if any. When present,
  -- occurrences of the same datatype in fields will be rendered as
  -- {"$ref": "#/$defs/<root>"} to avoid infinite recursion.
  gToJSONSchema :: (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (f a) -> Value

-- | Instance for empty types (no constructors).
--
-- Empty types are represented as JSON null since they
-- can never have a value.
instance GToJSONSchema V1 where
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (V1 a) -> Value
gToJSONSchema Bool
_ Maybe Text
_ Proxy (V1 a)
_ = Value
Null

-- | Instance for unit types (constructors with no fields).
--
-- Unit constructors are represented as null when untagged,
-- or as objects with just a tag field when tagged.
instance GToJSONSchema U1 where
  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (U1 a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (U1 a) -> Value
gToJSONSchema Bool
_ Maybe Text
_ Proxy (U1 a)
_ = Value
Null

-- | Instance for sum types (multiple constructors).
--
-- Sum types are encoded using JSON Schema's "anyOf" keyword,
-- allowing the value to match any of the constructor schemas.
--
-- Example:
-- @
-- data Color = Red | Green | Blue
-- -- Generates: {"anyOf": [{...Red schema}, {...Green schema}, {...Blue schema}]}
-- @
instance (GToJSONSchema f1, GToJSONSchema f2) => GToJSONSchema (f1 :+: f2) where
  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:+:) f1 f2 a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy ((:+:) f1 f2 a) -> Value
gToJSONSchema Bool
_ Maybe Text
root_name Proxy ((:+:) f1 f2 a)
_ =
    let v1 :: Value
v1 = Key -> Value -> Value
flattenKeys Key
"anyOf" (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Proxy (f1 a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f1 a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
True Maybe Text
root_name (Proxy (f1 a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f1 a))
        v2 :: Value
v2 = Key -> Value -> Value
flattenKeys Key
"anyOf" (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Proxy (f2 a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f2 a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
True Maybe Text
root_name (Proxy (f2 a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f2 a))
    in  case (Value
v1, Value
v2) of
          (Object Object
km1, Object Object
km2)
            | Just (Array Array
vec1) <- Object
km1 Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"anyOf"
            , Just (Array Array
vec2) <- Object
km2 Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"anyOf" ->
                [Pair] -> Value
object [Key
"anyOf" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Array (Array
vec1 Array -> Array -> Array
forall a. Semigroup a => a -> a -> a
<> Array
vec2)]
          (Object Object
km1, Object Object
km2)
            | Just (Array Array
vec) <- Object
km1 Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"anyOf"
            , Maybe Value
Nothing <- Object
km2 Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"anyOf" ->
                [Pair] -> Value
object [Key
"anyOf" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Array (Array
vec Array -> Value -> Array
forall a. Vector a -> a -> Vector a
`V.snoc` Value
v2)]
          (Object Object
_, Object Object
km2)
            | Just (Array Array
vec) <- Object
km2 Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"anyOf" ->
                [Pair] -> Value
object [Key
"anyOf" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Array -> Value
Array (Value
v1 Value -> Array -> Array
forall a. a -> Vector a -> Vector a
`V.cons` Array
vec)]
          (Value
_, Value
_) -> [Pair] -> Value
object [Key
"anyOf" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Value
v1, Value
v2]]

-- | Instance for product types (multiple fields in a constructor).
--
-- Non-record products are encoded as fixed-length arrays where
-- each position has a specific type. The "items": false ensures
-- no additional array elements are allowed.
--
-- Example:
-- @
-- data Point = Point Double Double
-- -- Generates: {"type": "array", "prefixItems": [{"type": "number"}, {"type": "number"}], "items": false}
-- @
instance (GToJSONSchema f1, GToJSONSchema f2) => GToJSONSchema (f1 :*: f2) where
  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy ((:*:) f1 f2 a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy ((:*:) f1 f2 a) -> Value
gToJSONSchema Bool
_ Maybe Text
root_name Proxy ((:*:) f1 f2 a)
_ =
    [Pair] -> Value
object
      [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"array" :: Text)
      , Key
"prefixItems"
          Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ Bool -> Maybe Text -> Proxy (f1 a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f1 a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
False Maybe Text
root_name (Proxy (f1 a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f1 a))
             , Bool -> Maybe Text -> Proxy (f2 a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f2 a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
False Maybe Text
root_name (Proxy (f2 a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f2 a))
             ]
      , Key
"items" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
      ]

-- | Helper to flatten nested array structures in schemas.
--
-- When building schemas for nested product types, we may get
-- structures like prefixItems: [a, {prefixItems: [b, c]}].
-- This function flattens them to prefixItems: [a, b, c] for
-- consistency with how Aeson represents such types.
flattenKeys :: Key -> Value -> Value
flattenKeys :: Key -> Value -> Value
flattenKeys Key
key (Object Object
km)
  | Just (Array Array
vec) <- Object
km Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
key
  , Array -> Int
forall a. Vector a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Array
vec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
  , Value
vf <- Array -> Value
forall a. Vector a -> a
V.head Array
vec
  , Object Object
vlkm <- Key -> Value -> Value
flattenKeys Key
key (Array -> Value
forall a. Vector a -> a
V.last Array
vec)
  , Just (Array Array
vec') <- Object
vlkm Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
key =
      Object -> Value
Object
        ( Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton
            Key
key
            (Array -> Value
Array (Value -> Array -> Array
forall a. a -> Vector a -> Vector a
V.cons Value
vf Array
vec'))
            Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
`KM.union` Object
km
        )
flattenKeys Key
_ Value
o = Value
o

-- | Instance for datatype metadata.
-- If this is the root, we output a $defs section with the type name and schema,
-- and refer to that in $ref.
instance (KnownSymbol dtn, GToJSONSchema f) => GToJSONSchema (D1 (MetaData dtn m p nt) f) where
  gToJSONSchema
    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (D1 (MetaData dtn m p nt) f a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool
-> Maybe Text -> Proxy (D1 ('MetaData dtn m p nt) f a) -> Value
gToJSONSchema Bool
_ Maybe Text
root_name Proxy (D1 ('MetaData dtn m p nt) f a)
_ =
    let dt_name :: String
dt_name = Proxy dtn -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy dtn
forall {k} (t :: k). Proxy t
Proxy :: Proxy dtn)
        this_name :: Text
this_name = String -> Text
pack String
dt_name
        body :: Value
body = Bool -> Maybe Text -> Proxy (f a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
False (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
this_name) (Proxy (f a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f a))
    in  case Maybe Text
root_name of
          -- Top-level: wrap with $defs and $ref to support recursion
          Maybe Text
Nothing ->
            [Pair] -> Value
object
              [ Key
"$defs" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [String -> Key
forall a. IsString a => String -> a
fromString String
dt_name Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
body]
              , Key
"$ref" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"#/$defs/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
this_name)
              ]
          -- Nested: just return the documented body
          Just Text
_ -> Value
body

-- | Instance for type constants (actual field types).
--
-- This delegates to the ToJSONSchema instance of the field type,
-- allowing custom schemas for specific types.
instance (ToJSONSchema c, Typeable c) => GToJSONSchema (K1 i c) where
  gToJSONSchema :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (K1 i c a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (K1 i c a) -> Value
gToJSONSchema Bool
_ Maybe Text
root_name Proxy (K1 i c a)
_ =
    case Maybe Text
root_name of
      -- If we know the root type name and the field type equals the root
      -- type, emit a $ref to the root definition to avoid infinite recursion.
      Just Text
nm ->
        if Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy c -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy c
forall {k} (t :: k). Proxy t
Proxy :: Proxy c)
          then [Pair] -> Value
object [Key
"$ref" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"#/$defs/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm)]
          else Proxy c -> Value
forall a. ToJSONSchema a => Proxy a -> Value
toJSONSchema (Proxy c
forall {k} (t :: k). Proxy t
Proxy :: Proxy c)
      Maybe Text
Nothing -> Proxy c -> Value
forall a. ToJSONSchema a => Proxy a -> Value
toJSONSchema (Proxy c
forall {k} (t :: k). Proxy t
Proxy :: Proxy c)

-- | Instance for record constructors.
--
-- Record types are encoded as objects with named properties.
-- When in a tagged sum type, adds a "tag" field with the
-- constructor name for discrimination.
--
-- Example:
-- @
-- data Person = Person {name :: Text, age :: Int}
-- -- Generates: {
-- --   "type": "object",
-- --   "properties": {
-- --     "name": {"type": "string"},
-- --     "age": {"type": "integer"}
-- --   },
-- --   "additionalProperties": false
-- -- }
-- @
instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity True) f) where
  gToJSONSchema
    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity True) f a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool
-> Maybe Text
-> Proxy (C1 ('MetaCons name fixity 'True) f a)
-> Value
gToJSONSchema Bool
tagged Maybe Text
root_name Proxy (C1 ('MetaCons name fixity 'True) f a)
_ =
    let props_val :: Value
props_val = Value -> Value
extractProperties (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Proxy (f a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
tagged Maybe Text
root_name (Proxy (f a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f a))
        props_keys :: [Text]
props_keys =
          case Value
props_val of
            Object Object
km -> (Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Text
K.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
km)
            Value
_ -> []
        requiredFields :: [Text]
requiredFields =
          (if Bool
tagged then (Text
"tag" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) else [Text] -> [Text]
forall a. a -> a
id) [Text]
props_keys
        requiredPairs :: [Pair]
requiredPairs =
          if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
requiredFields
            then []
            else [Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Text]
requiredFields]
    in  [Pair] -> Value
object
          ( [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
            , Key
"properties" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= if Bool
tagged then Value -> Value
addTag Value
props_val else Value
props_val
            , Key
"additionalProperties" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
            ]
              [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
requiredPairs
          )
    where
      tag :: Value
tag = [Pair] -> Value
object [Key
"const" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
cn]
      addTag :: Value -> Value
addTag (Object Object
km) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton (String -> Key
forall a. IsString a => String -> a
fromString String
"tag") Value
tag Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
`KM.union` Object
km
      addTag Value
o = Value
o
      xP :: Value -> Maybe Object
xP (Object Object
p) | Just (Object Object
r) <- Object
p Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"properties" = Object -> Maybe Object
forall a. a -> Maybe a
Just Object
r
      xP Value
_ = Maybe Object
forall a. Maybe a
Nothing
      cn :: String
cn = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name)
      extractProperties :: Value -> Value
      extractProperties :: Value -> Value
extractProperties o :: Value
o@(Object Object
_)
        | Object Object
km <- Key -> Value -> Value
flattenKeys Key
"prefixItems" Value
o
        , Just (Array Array
vec) <- Object
km Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"prefixItems"
        , (Value -> Bool) -> Array -> Bool
forall a. (a -> Bool) -> Vector a -> Bool
V.all (Maybe Object -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Object -> Bool) -> (Value -> Maybe Object) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Object
xP) Array
vec =
            Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Object -> Object -> Object) -> Object -> Vector Object -> Object
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
KM.union Object
forall v. KeyMap v
KM.empty (Vector Object -> Object) -> Vector Object -> Object
forall a b. (a -> b) -> a -> b
$ (Value -> Maybe Object) -> Array -> Vector Object
forall a b. (a -> Maybe b) -> Vector a -> Vector b
V.mapMaybe Value -> Maybe Object
xP Array
vec
      extractProperties (Object Object
km) | Just Value
p <- Object
km Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"properties" = Value
p
      extractProperties Value
o = Value
o

-- | Instance for non-record constructors.
--
-- Non-record constructors with multiple fields are encoded as arrays.
-- When in a tagged sum type, wraps in an object with "tag" and "contents".
--
-- Examples:
-- @
-- data Point = Point Double Double
-- -- Untagged: {"type": "array", "prefixItems": [...], "items": false}
--
-- data Shape = Circle Double | Rectangle Double Double
-- -- Tagged: {
-- --   "type": "object",
-- --   "properties": {
-- --     "tag": {"const": "Circle"},
-- --     "contents": {"type": "number"}
-- --   }
-- -- }
-- @
instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (C1 (MetaCons name fixity False) f) where
  gToJSONSchema
    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (C1 (MetaCons name fixity False) f a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool
-> Maybe Text
-> Proxy (C1 ('MetaCons name fixity 'False) f a)
-> Value
gToJSONSchema Bool
tagged Maybe Text
root_name Proxy (C1 ('MetaCons name fixity 'False) f a)
_ =
    let c_val :: Value
c_val = Key -> Value -> Value
flattenKeys Key
"prefixItems" (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Proxy (f a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
False Maybe Text
root_name (Proxy (f a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f a))
        c_name :: String
c_name = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name)
        tag :: Value
tag = [Pair] -> Value
object [Key
"const" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
c_name]
    in  case Value
c_val of
          o :: Value
o@(Object Object
km) ->
            let obj :: Value
obj = case Object
km Object -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
KM.!? Key
"prefixItems" of
                  Just pfi :: Value
pfi@(Array Array
_) -> [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"array" :: Text), Key
"prefixItems" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
pfi, Key
"items" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False]
                  Maybe Value
_ -> Value
o
                basePairs :: [Pair]
basePairs =
                  [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
                  , Key
"properties" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
tag, Key
"contents" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
obj]
                  , Key
"additionalProperties" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
                  ]
                requiredPairs :: [Pair]
requiredPairs =
                  [Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([Text
"tag", Text
"contents"] :: [Text])]
            in  if Bool
tagged
                  then
                    [Pair] -> Value
object ([Pair]
basePairs [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
requiredPairs)
                  else Value
obj
          Value
Null ->
            [Pair] -> Value
object
              [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
              , Key
"properties" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"tag" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
tag]
              , Key
"additionalProperties" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
False
              , Key
"required" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([ Text
"tag" ] :: [Text])
              ]
          Value
x -> Value
x

-- | Instance for unnamed fields (positional constructor arguments).
--
-- Simply delegates to the field type's schema without wrapping.
instance (GToJSONSchema f) => GToJSONSchema (S1 (MetaSel Nothing su ss ds) f) where
  gToJSONSchema
    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel Nothing su ss ds) f a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool
-> Maybe Text
-> Proxy (S1 ('MetaSel 'Nothing su ss ds) f a)
-> Value
gToJSONSchema Bool
_ Maybe Text
root_name Proxy (S1 ('MetaSel 'Nothing su ss ds) f a)
_ = Bool -> Maybe Text -> Proxy (f a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
False Maybe Text
root_name (Proxy (f a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f a))

-- | Instance for named record fields.
--
-- Creates an object schema with a single property named after
-- the field. These are combined by the record constructor instance.
--
-- Example:
-- @
-- data Person = Person { name :: Text }
-- -- For the 'name' field generates:
-- -- {
-- --   "type": "object",
-- --   "properties": {
-- --     "name": {"type": "string"}
-- --   }
-- -- }
-- @
instance (KnownSymbol name, GToJSONSchema f) => GToJSONSchema (S1 (MetaSel (Just name) su ss ds) f) where
  gToJSONSchema
    :: forall a. (ToJSONSchema a, Typeable a) => Bool -> Maybe Text -> Proxy (S1 (MetaSel (Just name) su ss ds) f a) -> Value
  gToJSONSchema :: forall a.
(ToJSONSchema a, Typeable a) =>
Bool
-> Maybe Text
-> Proxy (S1 ('MetaSel ('Just name) su ss ds) f a)
-> Value
gToJSONSchema Bool
_ Maybe Text
root_name Proxy (S1 ('MetaSel ('Just name) su ss ds) f a)
_ =
    [Pair] -> Value
object
      [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"object" :: Text)
      , Key
"properties"
          Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ String -> Key
forall a. IsString a => String -> a
fromString (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall {k} (t :: k). Proxy t
Proxy :: Proxy name)) Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool -> Maybe Text -> Proxy (f a) -> Value
forall a.
(ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
forall (f :: * -> *) a.
(GToJSONSchema f, ToJSONSchema a, Typeable a) =>
Bool -> Maybe Text -> Proxy (f a) -> Value
gToJSONSchema Bool
False Maybe Text
root_name (Proxy (f a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f a))
            ]
      ]