{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

{-|
Module      : Polytropos.OpenApi
Description : OpenAPI 3.0 schema generation for Polytropos records and variants
Copyright   : (c) 2026 The Polytropos Authors
License     : EUPL-1.2 OR Apache-2.0
Maintainer  : nadia.yvette.chambers@ik.me
Stability   : experimental
Portability : non-portable (GHC extensions)

Generates OpenAPI 3.0 schema specifications directly from @polytropos@
open records and variants.

= Architectural Overview & Rationale

== Schema Shape

* A record declares an anonymous object schema whose @properties@ carry one
  entry per field (reified from the row symbols) and whose @required@ list
  contains every field: a row-typed record is total, so all fields are required.
* A variant declares an anonymous @oneOf@ schema with one entry per constructor,
  each a single-member tagged object @{"ctor": fields}@ — the same wire shape
  "Polytropos.Aeson" uses, so REST APIs documented by these schemas round-trip seamlessly.

== Eliminating Generic Schema Blow-up

Standard @ToSchema@ deriving walks a "GHC.Generics" tree, which causes severe
slowdowns on large schema models (50+ fields). @polytropos-openapi3@ synthesizes
the schema by directly traversing the row type—one 'Declare' step per field—with
zero generic overhead.

= When to Use This Module

* When documenting REST APIs, Swagger / OpenAPI endpoints that produce or consume
  @polytropos@ records and variants.

= Worked Example

> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE TypeApplications #-}
> {-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}
>
> import Data.OpenApi (toSchema, Schema)
> import Data.Proxy (Proxy (..))
> import Polytropos
> import Polytropos.OpenApi
>
> type User = Record '["id" ':= Int, "name" ':= String]
>
> -- A conforming record value:
> userVal :: User
> userVal = REC { id = 1, name = "Alice" }
>
> -- Generated OpenAPI schema with properties and required list in row order:
> userSchema :: Schema
> userSchema = toSchema (Proxy @User)
-}
module Polytropos.OpenApi
  ( -- * Row Schema Walkers
    AllToSchema (..)
  , AllCtorsToSchema (..)
  ) where

import Control.Lens ((&), (.~), (?~))
import Data.Proxy            (Proxy (..))
import Data.Typeable         (Typeable)
import Data.Text             (Text)
import qualified Data.Text as T
import GHC.TypeLits          (KnownSymbol, symbolVal)
import Data.OpenApi
import Data.OpenApi.Declare (Declare)
import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM
import Polytropos            (Record, Variant)
import Polytropos.Core       (Pair (..), Row, SumRow)

{-------------------------------------------------------------------------------
  Row schema walkers
-------------------------------------------------------------------------------}

-- | One property entry per field of the row, in row order.
class AllToSchema (r :: Row) where
  fieldSchemas :: Proxy r -> Declare (Definitions Schema) [(Text, Referenced Schema)]

instance AllToSchema '[] where
  fieldSchemas :: Proxy '[]
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
fieldSchemas Proxy '[]
_ = [(Text, Referenced Schema)]
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (KnownSymbol n, ToSchema a, AllToSchema r)
      => AllToSchema ((n ':= a) ': r) where
  fieldSchemas :: Proxy ((n ':= a) : r)
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
fieldSchemas Proxy ((n ':= a) : r)
_ = do
    s  <- Proxy a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
    ss <- fieldSchemas (Proxy @r)
    pure ((T.pack (symbolVal (Proxy @n)), s) : ss)

-- | One tagged object schema per constructor of the sum row.
class AllCtorsToSchema (s :: SumRow) where
  ctorSchemas :: Proxy s -> Declare (Definitions Schema) [Schema]

instance AllCtorsToSchema '[] where
  ctorSchemas :: Proxy '[] -> Declare (Definitions Schema) [Schema]
ctorSchemas Proxy '[]
_ = [Schema] -> Declare (Definitions Schema) [Schema]
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (KnownSymbol c, AllToSchema fs, AllCtorsToSchema s)
      => AllCtorsToSchema ((c ':= fs) ': s) where
  ctorSchemas :: Proxy ((c ':= fs) : s) -> Declare (Definitions Schema) [Schema]
ctorSchemas Proxy ((c ':= fs) : s)
_ = do
    fields <- Proxy fs
-> Declare (Definitions Schema) [(Text, Referenced Schema)]
forall (r :: Row).
AllToSchema r =>
Proxy r -> Declare (Definitions Schema) [(Text, Referenced Schema)]
fieldSchemas (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @fs)
    let fieldsObj = Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. Hashable k => [(k, v)] -> InsOrdHashMap k v
IOHM.fromList [(Text, Referenced Schema)]
fields
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((Text, Referenced Schema) -> Text)
-> [(Text, Referenced Schema)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Referenced Schema) -> Text
forall a b. (a, b) -> a
fst [(Text, Referenced Schema)]
fields
        tagged = Schema
forall a. Monoid a => a
mempty
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. Hashable k => [(k, v)] -> InsOrdHashMap k v
IOHM.fromList [(String -> Text
T.pack (Proxy c -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @c)), Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
fieldsObj)]
          Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [String -> Text
T.pack (Proxy c -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @c))]
    (tagged :) <$> ctorSchemas (Proxy @s)

{-------------------------------------------------------------------------------
  Instances
-------------------------------------------------------------------------------}

instance (Typeable r, AllToSchema r) => ToSchema (Record r) where
  declareNamedSchema :: Proxy (Record r) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Record r)
_ = do
    fields <- Proxy r -> Declare (Definitions Schema) [(Text, Referenced Schema)]
forall (r :: Row).
AllToSchema r =>
Proxy r -> Declare (Definitions Schema) [(Text, Referenced Schema)]
fieldSchemas (forall (t :: Row). Proxy t
forall {k} (t :: k). Proxy t
Proxy @r)
    pure $ NamedSchema Nothing $ mempty
      & type_ ?~ OpenApiObject
      & properties .~ IOHM.fromList fields
      & required .~ map fst fields

instance (Typeable s, AllCtorsToSchema s) => ToSchema (Variant s) where
  declareNamedSchema :: Proxy (Variant s) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Variant s)
_ = do
    ctors <- Proxy s -> Declare (Definitions Schema) [Schema]
forall (s :: SumRow).
AllCtorsToSchema s =>
Proxy s -> Declare (Definitions Schema) [Schema]
ctorSchemas (forall (t :: SumRow). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s)
    pure $ NamedSchema Nothing $ mempty
      & oneOf ?~ map Inline ctors