fix(haskell): don't over-rename enum cases when the enum suffix already disambiguates

packages/quicktype-core/src/language/Haskell/HaskellRenderer.ts

@@ -4,7 +4,7 @@ import {
     ConvenienceRenderer,
     type ForbiddenWordsInfo,
 } from "../../ConvenienceRenderer.js";
-import type { Name, Namer } from "../../Naming.js";
+import { DependencyName, type Name, type Namer } from "../../Naming.js";
 import type { RenderContext } from "../../Renderer.js";
 import type { OptionValues } from "../../RendererOptions/index.js";
 import {
@@ -73,6 +73,26 @@ export class HaskellRenderer extends ConvenienceRenderer {
         return true;
     }
 
+    protected makeNameForEnumCase(
+        e: EnumType,
+        enumName: Name,
+        caseName: string,
+        assignedName: string | undefined,
+    ): Name {
+        const name = super.makeNameForEnumCase(
+            e,
+            enumName,
+            caseName,
+            assignedName,
+        );
+        const proposedName = name.firstProposedName(new Map());
+        return new DependencyName(
+            name.namingFunction,
+            name.order,
+            (lookup) => `${proposedName}_${lookup(enumName)}`,
+        );
+    }
+
     protected proposeUnionMemberName(
         u: UnionType,
         unionName: Name,
@@ -226,14 +246,22 @@ export class HaskellRenderer extends ConvenienceRenderer {
         });
     }
 
+    private enumCaseName(name: Name, enumName: Name): Sourcelike {
+        return name instanceof DependencyName ? name : [name, enumName];
+    }
+
     private emitEnumDefinition(e: EnumType, enumName: Name): void {
         this.emitDescription(this.descriptionForType(e));
         this.emitLine("data ", enumName);
         this.indent(() => {
             let onFirst = true;
             this.forEachEnumCase(e, "none", (name) => {
                 const equalsOrPipe = onFirst ? "=" : "|";
-                this.emitLine(equalsOrPipe, " ", name, enumName);
+                this.emitLine(
+                    equalsOrPipe,
+                    " ",
+                    this.enumCaseName(name, enumName),
+                );
                 onFirst = false;
             });
             this.emitLine("deriving (Show)");
@@ -355,8 +383,7 @@ export class HaskellRenderer extends ConvenienceRenderer {
             this.forEachEnumCase(e, "none", (name, jsonName) => {
                 this.emitLine(
                     "toJSON ",
-                    name,
-                    enumName,
+                    this.enumCaseName(name, enumName),
                     ' = "',
                     stringEscape(jsonName),
                     '"',
@@ -377,8 +404,7 @@ export class HaskellRenderer extends ConvenienceRenderer {
                             'parseText "',
                             stringEscape(jsonName),
                             '" = return ',
-                            name,
-                            enumName,
+                            this.enumCaseName(name, enumName),
                         );
                     });
                 });

test/inputs/schema/haskell-enum-forbidden.1.fail.enum.json

@@ -0,0 +1,3 @@
+{
+    "health": "warning"
+}

test/inputs/schema/haskell-enum-forbidden.1.json

@@ -0,0 +1,3 @@
+{
+    "health": "error"
+}

test/inputs/schema/haskell-enum-forbidden.schema

@@ -0,0 +1,11 @@
+{
+    "$schema": "http://json-schema.org/draft-06/schema#",
+    "type": "object",
+    "properties": {
+        "health": {
+            "type": "string",
+            "enum": ["ok", "error"]
+        }
+    },
+    "required": ["health"]
+}

test/languages.ts

@@ -25,6 +25,7 @@ const skipsEnumValueValidation = [
     "enum-large.schema",
     "optional-enum.schema",
     "const-non-string.schema",
+    "haskell-enum-forbidden.schema",
     "nullable-optional-one-of.schema",
     "all-of-additional-properties-false.schema",
 ];

test/unit/haskell-enum-case-naming.test.ts

@@ -0,0 +1,75 @@
+import {
+    InputData,
+    JSONSchemaInput,
+    quicktype,
+} from "../../packages/quicktype-core/src/index.js";
+import { describe, expect, test } from "vitest";
+
+async function renderHaskell(schema: object): Promise<string> {
+    const schemaInput = new JSONSchemaInput(undefined);
+    await schemaInput.addSource({
+        name: "TopLevel",
+        schema: JSON.stringify(schema),
+    });
+
+    const inputData = new InputData();
+    inputData.addInput(schemaInput);
+
+    const result = await quicktype({
+        inputData,
+        lang: "haskell",
+    });
+    return result.lines.join("\n");
+}
+
+function enumConstructors(output: string): string[] {
+    // Collect the constructors of the generated `data Health` declaration,
+    // which are emitted one per line as `= OkHealth` / `| ErrorHealth`.
+    const lines = output.split("\n");
+    const start = lines.findIndex((line) => line.startsWith("data Health"));
+    if (start < 0) {
+        return [];
+    }
+
+    const constructors: string[] = [];
+    for (const line of lines.slice(start + 1)) {
+        const match = line.match(/^\s*[=|]\s+(\S+)/);
+        if (match === null) {
+            break;
+        }
+
+        constructors.push(match[1]);
+    }
+
+    return constructors;
+}
+
+describe("Haskell enum case naming", () => {
+    // Enum cases are emitted as `<case><enumName>` so the enum name already
+    // disambiguates each constructor.  When a case name would otherwise be
+    // renamed to avoid a forbidden identifier (here `error`), the renderer
+    // must not compound the enum-name suffix on top of that rename.  A
+    // round-trip fixture cannot catch this: the constructor name is invisible
+    // to JSON serialization, so both the correct and the over-renamed output
+    // round-trip identically.  See issue #2868.
+    test("suffixes the enum name without over-renaming forbidden cases", async () => {
+        const schema = {
+            type: "object",
+            properties: {
+                health: {
+                    type: "string",
+                    enum: ["ok", "error"],
+                },
+            },
+            required: ["health"],
+        };
+
+        const output = await renderHaskell(schema);
+        const constructors = enumConstructors(output);
+
+        expect(constructors).toEqual(["OkHealth", "ErrorHealth"]);
+        // Guard against the specific regression: the "error" case being
+        // renamed to "HealthError" before the enum suffix is appended.
+        expect(output).not.toContain("HealthErrorHealth");
+    });
+});