Support polymorphic types by default

src/Data/OpenApi/Internal/Schema.hs

@@ -135,7 +135,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
 --
 -- instance ToSchema Coord
 -- @
-class ToSchema a where
+class Typeable a => ToSchema a where
   -- | Convert a type into an optionally named schema
   -- together with all used definitions.
   -- Note that the schema itself is included in definitions
@@ -610,7 +610,7 @@ instance ToSchema Scientific  where declareNamedSchema = plain . paramSchemaToSc
 instance ToSchema Double      where declareNamedSchema = plain . paramSchemaToSchema
 instance ToSchema Float       where declareNamedSchema = plain . paramSchemaToSchema
 
-instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
+instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
 
 instance ToSchema a => ToSchema (Maybe a) where
   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
@@ -627,12 +627,18 @@ instance ToSchema UUID.UUID where
   declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
     & example ?~ toJSON (UUID.toText UUID.nil)
 
-instance (ToSchema a, ToSchema b) => ToSchema (a, b)
-instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
-instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
-instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
-instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
-instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
+instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
+  declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
+  declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
+  declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
+  declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
+  declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
+  declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
 
 timeSchema :: T.Text -> Schema
 timeSchema fmt = mempty
@@ -683,7 +689,7 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
 instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
 
 -- | NOTE: This schema does not account for the uniqueness of keys.
-instance ToSchema a => ToSchema (IntMap a) where
+instance (ToSchema a) => ToSchema (IntMap a) where
   declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
 
 instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
@@ -853,17 +859,32 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.
 toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
 
 -- | A configurable generic @'Schema'@ creator.
-genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>
+genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
   SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
 genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
 
 -- | A configurable generic @'NamedSchema'@ creator.
 -- This function applied to @'defaultSchemaOptions'@
 -- is used as the default for @'declareNamedSchema'@
 -- when the type is an instance of @'Generic'@.
-genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
+--
+-- Default implementation will use the name from 'Typeable' instance, including concrete
+-- instantioations of type variables.
+--
+-- For example:
+--
+-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
+-- Just "Either_Int_Bool"
+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
   SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
-genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
+genericDeclareNamedSchema opts _ =
+  rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
+  where
+    unspace ' ' = '_'
+    unspace x = x
+    orig = fmap unspace $ show $ typeRep @a
+    name = datatypeNameModifier opts orig
+
 
 -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
 genericNameSchema :: forall a d f.
@@ -1089,49 +1110,6 @@ data Proxy2 a b = Proxy2
 
 data Proxy3 a b c = Proxy3
 
--- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
---
--- Intended usage:
---
--- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
--- >>> :{
--- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
---   declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
--- :}
---
--- >>> toNamedSchema @(Foo Int) Proxy ^. name
--- Just "Foo_Int"
--- >>> toNamedSchema @(Foo Bool) Proxy ^. name
--- Just "Foo_Bool"
--- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
--- Just "Foo_(Foo_Text)"
-class ToSchema1 (f :: * -> *) where
-  declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
-
-  -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
-  -- above, however sadly GHC does not like it.
-  default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
-  declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
-
-{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
-using 'ToSchema1' instance, like this:
-
-#if __GLASGOW_HASKELL__ >= 806
->>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
->>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
-#else
-> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
-> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
-#endif
--}
-newtype BySchema1 f a = BySchema1 (f a)
-
-instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where
-  declareNamedSchema _ = do
-    sch <- declareNamedSchema1 @f @a Proxy Proxy
-    let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
-    return $ rename (Just tName) sch
-
 {- $setup
 >>> import Data.OpenApi
 >>> import Data.Aeson (encode)
@@ -1141,7 +1119,4 @@ instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToS
 >>> :set -XDeriveAnyClass
 >>> :set -XStandaloneDeriving
 >>> :set -XTypeApplications
-#if __GLASGOW_HASKELL__ >= 806
->>> :set -XDerivingVia
-#endif
 -}

src/Data/OpenApi/Schema.hs

@@ -13,8 +13,6 @@ module Data.OpenApi.Schema (
   toSchemaRef,
   schemaName,
   toInlinedSchema,
-  ToSchema1(..),
-  BySchema1(..),
 
   -- * Generic schema encoding
   genericDeclareNamedSchema,