Do something clever with ToSchema for polymorphic types

Turns out someone just got "bitten" by ToSchema (Either a b) instance we have. Since Generic mechanism can't display names of the type parameters, we name all instances just "Either". Apart from bad naming this results in silent overwriting schemas in Definitions.

This turned out not good for one of IOHK's APIs (see here). They are using a lot of Either WalletError something as their response types. Although that's not idiomatic API design (WalletError should be returned with 400 or some other error HTTP code) this is how things are and there's no reason to reject Swagger for this API.

To facilitate this specific use I've come up with a simple fix:

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Lens
import Data.Typeable
import qualified Data.Text as Text

instance {-# OVERLAPPING #-} (Typeable a, ToSchema a) => ToSchema (Either WalletError a) where
  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
      & mapped.name ?~ Text.pack ("Either WalletError " ++ show (typeOf (undefined :: a)))

We can use a similar fix for all polymorphic types with named schemas:

instance (Typeable a, Typeable b, ToSchema a, ToSchema b)
  => ToSchema (Either a b) where
  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
      & mapped.name ?~ Text.pack ("Either " ++ aName ++ " " ++ bName)
    where
      aName = show (typeOf (undefined :: a))
      bName = show (typeOf (undefined :: b))

We can even make some helpers to avoid code duplication for custom polymorphic types:

genericDeclareNamedSchema1 :: forall t a. (...) =>
  SchemaOptions -> proxy (t a) -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema1 opts proxy = genericDeclareNamedSchema opts proxy
  & mapped.name ?~ Text.pack (tName ++ " " ++ aName)
  where
    tName = show (typeOf (undefined :: t))
    aName = show (typeOf (undefined :: a))

genericDeclareNamedSchema2 :: forall t a. (...) =>
  SchemaOptions -> proxy (t a b) -> Declare (Definitions Schema) NamedSchema

genericDeclareNamedSchema3 :: forall t a. (...) =>
  SchemaOptions -> proxy (t a b c) -> Declare (Definitions Schema) NamedSchema