Generates broken schema when I use custom sum type with Maybe in parameter

[s-and-witch]

Minimal example:

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Data.Proxy ( Proxy(Proxy) )
import Data.OpenApi ( ToSchema )
import Test.Hspec ( hspec )
import Test.QuickCheck.Arbitrary.Generic
    ( Arbitrary, GenericArbitrary(GenericArbitrary) )
import GHC.Generics (Generic)
import Data.Aeson ( FromJSON, ToJSON )
import Servant.OpenApi.Test ( validateEveryToJSON )
import Servant.API

data M a = J a | N
  deriving stock (Show, Generic)
  deriving anyclass (ToJSON,  FromJSON)
  deriving Arbitrary via GenericArbitrary (M a)

instance ToSchema a => ToSchema (M a)

data Foo = Foo (M (Maybe Int))
  deriving stock (Show, Generic)
  deriving anyclass (ToJSON,  FromJSON, ToSchema)
  deriving Arbitrary via GenericArbitrary Foo

type API = "foo" :> Get '[JSON] Foo

main :: IO ()
main = do
  let spec = validateEveryToJSON (Proxy @API)
  hspec spec

deps:

    , openapi3
    , hspec
    , generic-arbitrary >= 0.2 --used only to generate Arbitrary instances
    , aeson
    , servant
    , servant-openapi3 -- used only for hspec checking

Output:

Foo [✘]

Failures:

  src/Servant/OpenApi/Internal/Test.hs:137:15: 
  1) Foo
       Falsified (after 5 tests):
         Foo (J Nothing)
         Validation against the schema fails:
           * Value not valid under any of 'oneOf' schemas: Object (fromList [("contents",Null),("tag",String "J")])
         
         JSON value:
         {
             "contents": null,
             "tag": "J"
         }
         
         OpenApi Schema:
         {
             "oneOf": [
                 {
                     "properties": {
                         "contents": {
                             "maximum": 9223372036854775807,
                             "minimum": -9223372036854775808,
                             "type": "integer"
                         },
                         "tag": {
                             "enum": [
                                 "J"
                             ],
                             "type": "string"
                         }
                     },
                     "required": [
                         "tag",
                         "contents"
                     ],
                     "type": "object"
                 },
                 {
                     "properties": {
                         "tag": {
                             "enum": [
                                 "N"
                             ],
                             "type": "string"
                         }
                     },
                     "required": [
                         "tag"
                     ],
                     "type": "object"
                 }
             ],
             "type": "object"
         }

Explanation:

It happens because we have

                     "required": [
                         "tag",
                         "contents"
                     ]

in J brach, so when generated J Nothing, it turns into

         {
             "contents": null,
             "tag": "J"
         }

JSON, but contents field is required.

How to fix:

You can write an instance manually, without contents in required

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

...

import Control.Lens
import qualified Data.HashMap.Strict.InsOrd as InsMap

...

instance {-# OVERLAPPING #-} ToSchema a => ToSchema (M (Maybe a)) where
  declareNamedSchema _ = do
    nestedType <- declareSchemaRef (Proxy @a)
    let
      updateToTag = Inline $ mempty
        & type_ ?~ OpenApiString
        & enum_ ?~ [ "J" ]
      doNotUpdateTag = Inline $ mempty
        & type_ ?~ OpenApiString
        & enum_ ?~ [ "N" ]
      updateTo = Inline $ mempty
        & type_ ?~ OpenApiObject
        & properties .~ InsMap.fromList
          [ ("tag", updateToTag)
          , ("contents", nestedType)
          ]
        & required .~ ["tag"]
      doNotUpdate = Inline $ mempty
        & type_ ?~ OpenApiObject
        & properties .~ InsMap.fromList
          [ ("tag", doNotUpdateTag)
          ]
        & required .~ ["tag"]
    pure $ NamedSchema (Just "M") $ mempty
      & oneOf ?~ [updateTo, doNotUpdate]

...
deps:

    , lens
    , insert-ordered-containers

[maksbotan]

Generic schema generator for M a can't look into instantiations of the polymorphic types, because schema is already generated completely for M a, and is just reused for Foo. So, Maybe as type parameter is next to impossible to get right, as far as I know.