fixed: GToSchema: infinite call: single constructor and recur

src/Data/OpenApi/Internal/Schema.hs

@@ -945,10 +945,13 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
         case schema ^. items of
           Just (OpenApiItemsArray [_]) -> fieldSchema
           _ -> do
-            declare defs
-            return (unnamed schema)
+            -- We have to run recordSchema instead of just using its defs,
+            -- since those can be recursive and will lead to infinite loop,
+            -- see https://github.com/biocad/openapi3/pull/37
+            NamedSchema _ schema' <- recordSchema
+            return (unnamed schema')
     where
-      (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
+      (_, NamedSchema _ schema) = runDeclare recordSchema mempty
       recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
       fieldSchema  = gdeclareNamedSchema opts (Proxy :: Proxy f) s
 

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.8
+resolver: lts-16.31
 packages:
 - '.'
 extra-deps:

test/Data/OpenApi/CommonTestTypes.hs

@@ -863,6 +863,129 @@ singleMaybeFieldSchemaJSON = [aesonQQ|
 }
 |]
 
+-- ========================================================================
+-- Natural Language (single field data with recursive fields)
+-- ========================================================================
+
+data Predicate
+  = PredicateNoun    Noun
+  | PredicateOmitted Omitted
+  deriving (Eq, Ord, Read, Show, Generic)
+instance ToJSON Predicate
+instance ToSchema Predicate
+
+data Noun
+  = Noun
+  { nounSurf   :: LangWord
+  , nounModify :: [Modifier]
+  }
+  deriving (Eq, Ord, Read, Show, Generic)
+instance ToJSON Noun
+instance ToSchema Noun
+
+data LangWord
+  = LangWord
+  { langWordSurf :: String
+  , langWordBase :: String
+  }
+  deriving (Eq, Ord, Read, Show, Generic)
+instance ToJSON LangWord
+instance ToSchema LangWord
+
+data Modifier
+  = ModifierNoun     Noun
+  | ModifierOmitted  Omitted
+  deriving (Eq, Ord, Read, Show, Generic)
+instance ToJSON Modifier
+instance ToSchema Modifier
+
+newtype Omitted
+  = Omitted
+  { omittedModify :: [Modifier]
+  }
+  deriving (Eq, Ord, Read, Show, Generic)
+instance ToJSON Omitted
+instance ToSchema Omitted
+
+predicateSchemaDeclareJSON :: Value
+predicateSchemaDeclareJSON = [aesonQQ|
+[
+  {
+    "Predicate": {
+      "oneOf": [
+        {
+          "properties": {
+            "contents": { "$ref": "#/components/schemas/Noun" },
+            "tag": { "enum": ["PredicateNoun"], "type": "string" }
+          },
+          "required": ["tag", "contents"],
+          "type": "object"
+        },
+        {
+          "properties": {
+            "contents": { "$ref": "#/components/schemas/Omitted" },
+            "tag": { "enum": ["PredicateOmitted"], "type": "string" }
+          },
+          "required": ["tag", "contents"],
+          "type": "object"
+        }
+      ],
+      "type": "object"
+    },
+    "Noun": {
+      "properties": {
+        "nounModify": {
+          "items": { "$ref": "#/components/schemas/Modifier" },
+          "type": "array"
+        },
+        "nounSurf": { "$ref": "#/components/schemas/LangWord" }
+      },
+      "required": ["nounSurf", "nounModify"],
+      "type": "object"
+    },
+    "LangWord": {
+      "properties": {
+        "langWordBase": { "type": "string" },
+        "langWordSurf": { "type": "string" }
+      },
+      "required": ["langWordSurf", "langWordBase"],
+      "type": "object"
+    },
+    "Modifier": {
+      "oneOf": [
+        {
+          "properties": {
+            "contents": { "$ref": "#/components/schemas/Noun" },
+            "tag": { "enum": ["ModifierNoun"], "type": "string" }
+          },
+          "required": ["tag", "contents"],
+          "type": "object"
+        },
+        {
+          "properties": {
+            "contents": { "$ref": "#/components/schemas/Omitted" },
+            "tag": { "enum": ["ModifierOmitted"], "type": "string" }
+          },
+          "required": ["tag", "contents"],
+          "type": "object"
+        }
+      ],
+      "type": "object"
+    },
+    "Omitted": {
+      "properties": {
+        "omittedModify": {
+          "items": { "$ref": "#/components/schemas/Modifier" },
+          "type": "array"
+        }
+      },
+      "required": ["omittedModify"],
+      "type": "object"
+    }
+  },
+  { "$ref": "#/components/schemas/Predicate" }
+]
+|]
 
 -- ========================================================================
 -- TimeOfDay

test/Data/OpenApi/SchemaSpec.hs

@@ -59,6 +59,9 @@ checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
   where
     (defs, s) = runDeclare (declareSchema proxy) mempty
 
+checkToSchemaDeclare :: (HasCallStack, ToSchema a) => Proxy a -> Value -> Spec
+checkToSchemaDeclare proxy js = runDeclare (declareSchemaRef proxy) mempty <=> js
+
 spec :: Spec
 spec = do
   describe "Generic ToSchema" $ do
@@ -78,6 +81,7 @@ spec = do
       context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
       context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
       context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
+      context "Natural Language (single field data with recursive fields)" $ checkToSchemaDeclare (Proxy :: Proxy Predicate) predicateSchemaDeclareJSON
     context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
     context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
     context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'