fix: name generation of component object

src/Data/OpenApi/SchemaOptions.hs

@@ -1,13 +1,19 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
 -- |
 -- Module:      Data.OpenApi.SchemaOptions
 -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>
 -- Stability:   experimental
 --
 -- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
-module Data.OpenApi.SchemaOptions where
+module Data.OpenApi.SchemaOptions (
+    SchemaOptions (..)
+  , defaultSchemaOptions
+  , fromAesonOptions
+) where
 
 import qualified Data.Aeson.Types as Aeson
+import Data.Char
 
 -- | Options that specify how to encode your type to Swagger schema.
 data SchemaOptions = SchemaOptions
@@ -40,14 +46,26 @@ data SchemaOptions = SchemaOptions
 -- @
 defaultSchemaOptions :: SchemaOptions
 defaultSchemaOptions = SchemaOptions
+  -- \x -> traceShowId x
   { fieldLabelModifier = id
   , constructorTagModifier = id
-  , datatypeNameModifier = id
+  , datatypeNameModifier = conformDatatypeNameModifier
   , allNullaryToStringTag = True
   , unwrapUnaryRecords = False
   , sumEncoding = Aeson.defaultTaggedObject
   }
 
+
+-- | According to spec https://github.com/OAI/OpenAPI-Specification/blob/main/versions/3.0.3.md#components-object 
+-- name must conform to ^[a-zA-Z0-9\.\-_]+$
+conformDatatypeNameModifier :: String -> String
+conformDatatypeNameModifier = 
+  foldl (\acc x -> acc ++ convertChar x) ""  
+  where 
+    convertChar = \case 
+      c | isAlphaNum c || elem c "-._" -> [c]
+      c -> "_" ++ (show $ ord c) ++ "_"
+
 -- | Convert 'Aeson.Options' to 'SchemaOptions'.
 --
 -- Specifically the following fields get copied:

test/Data/OpenApi/CommonTestTypes.hs

@@ -258,6 +258,30 @@ playersSchemaJSON = [aesonQQ|
 }
 |]
 
+-- ========================================================================
+-- Player (with type param)
+-- ========================================================================
+
+newtype PlayerPoly a = PlayerPoly
+  { position' :: PointG a
+  } deriving (Generic)
+instance (ToSchema a) => ToSchema (PlayerPoly a)
+
+playerPolySchemaJSON :: Value
+playerPolySchemaJSON = [aesonQQ|
+{
+  "type": "object",
+  "properties":
+    {
+      "position":
+        {
+          "$ref": "#/components/schemas/Point"
+        }
+    },
+  "required": ["position"]
+}
+|]
+
 -- ========================================================================
 -- Character (sum type with ref and record in alternative)
 -- ========================================================================
@@ -505,6 +529,18 @@ pointSchemaJSON = [aesonQQ|
 }
 |]
 
+-- ========================================================================
+-- Point (record data type with custom fieldLabelModifier)
+-- ========================================================================
+
+data PointG a = PointG
+  { pointGX :: a
+  , pointGY :: a
+  } deriving (Generic)
+
+instance ToSchema a => ToSchema (PointG a) where
+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
+
 -- ========================================================================
 -- Point (record data type with multiple fields)
 -- ========================================================================

test/Data/OpenApi/SchemaSpec.hs

@@ -95,6 +95,7 @@ spec = do
       context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
       context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
       context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
+      context "Player (polymorphic record)" $ checkSchemaName (Just "PlayerPoly__40_PointG_Int_41_") (Proxy :: Proxy (PlayerPoly (PointG Int)))
   describe "Generic Definitions" $ do
     context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
     context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]