Skip to content

Commit 6866979

Browse files
adzadz
committed
Separate tagged union error behavior tests
1 parent 0039250 commit 6866979

10 files changed

Lines changed: 153 additions & 118 deletions

File tree

‎docs/HOW_TO_EXPORT_JSON_SCHEMA.md‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -95,8 +95,8 @@ type Status =
9595
9696
let statusSchema =
9797
Schema.union [
98-
Schema.case0 "pending" Pending ((=) Pending)
99-
Schema.case1
98+
Schema.tag "pending" Pending ((=) Pending)
99+
Schema.tagWith
100100
"failed"
101101
(function Failed message -> Some message | _ -> None)
102102
Failed
@@ -120,12 +120,12 @@ type RecursiveNode =
120120
let rec nodeSchema : Schema<RecursiveNode> =
121121
Schema.delay (fun () ->
122122
Schema.union [
123-
Schema.case1
123+
Schema.tagWith
124124
"leaf"
125125
(function Leaf value -> Some value | _ -> None)
126126
Leaf
127127
Schema.string
128-
Schema.case1
128+
Schema.tagWith
129129
"branch"
130130
(function Branch value -> Some value | _ -> None)
131131
Branch

‎docs/HOW_TO_MODEL_A_RECURSIVE_TAGGED_UNION.md‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -21,14 +21,14 @@ type RecursiveNode =
2121
let rec nodeSchema : Schema<RecursiveNode> =
2222
delay (fun () ->
2323
union [
24-
case1
24+
tagWith
2525
"leaf"
2626
(function
2727
| Leaf value -> Some value
2828
| _ -> None)
2929
Leaf
3030
string
31-
case1
31+
tagWith
3232
"branch"
3333
(function
3434
| Branch value -> Some value
@@ -77,13 +77,15 @@ value.value.value=ok
7777

7878
Use these helpers:
7979

80-
- `case0` for a case with no payload
81-
- `case1` for a case with exactly one payload value
80+
- `tag` for a tag without payload
81+
- `tagWith` for a tag with exactly one payload value
8282
- `union` for the default field names `"case"` and `"value"`
8383
- `unionNamed` when another system expects different field names
8484

8585
If you need the exact emitted JSON, XML, YAML, or KeyValue shapes, see [Tagged Union Wire Shape Reference](TAGGED_UNION_REFERENCE.md).
8686

87+
If you want concrete malformed payload examples and the exact failure messages the codecs are expected to produce, see [`tests/CodecMapper.Tests/TaggedUnionErrorTests.fs`](../tests/CodecMapper.Tests/TaggedUnionErrorTests.fs).
88+
8789
Example with a payload-free case and custom field names:
8890

8991
```fsharp
@@ -93,8 +95,8 @@ type Status =
9395
9496
let statusSchema =
9597
unionNamed "kind" "details" [
96-
case0 "pending" Pending ((=) Pending)
97-
case1
98+
tag "pending" Pending ((=) Pending)
99+
tagWith
98100
"failed"
99101
(function Failed message -> Some message | _ -> None)
100102
Failed

‎docs/TAGGED_UNION_REFERENCE.md‎

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,8 @@
22

33
This page is for lookup once you already know the authored tagged-union API:
44

5-
- `Schema.case0`
6-
- `Schema.case1`
5+
- `Schema.tag`
6+
- `Schema.tagWith`
77
- `Schema.union`
88
- `Schema.unionNamed`
99
- `Schema.delay`
@@ -29,8 +29,8 @@ type Status =
2929
3030
let statusSchema =
3131
union [
32-
case0 "pending" Pending ((=) Pending)
33-
case1
32+
tag "pending" Pending ((=) Pending)
33+
tagWith
3434
"failed"
3535
(function Failed message -> Some message | _ -> None)
3636
Failed
@@ -108,8 +108,8 @@ Example:
108108
```fsharp
109109
let statusSchema =
110110
unionNamed "kind" "details" [
111-
case0 "pending" Pending ((=) Pending)
112-
case1
111+
tag "pending" Pending ((=) Pending)
112+
tagWith
113113
"failed"
114114
(function Failed message -> Some message | _ -> None)
115115
Failed
@@ -157,12 +157,12 @@ type RecursiveNode =
157157
let rec nodeSchema : Schema<RecursiveNode> =
158158
delay (fun () ->
159159
union [
160-
case1
160+
tagWith
161161
"leaf"
162162
(function Leaf value -> Some value | _ -> None)
163163
Leaf
164164
string
165-
case1
165+
tagWith
166166
"branch"
167167
(function Branch value -> Some value | _ -> None)
168168
Branch
@@ -188,3 +188,5 @@ The codecs currently reject:
188188
- stray payload keys for payload-free KeyValue cases
189189

190190
For KeyValue specifically, the payload-free case check matters because extra flattened keys would otherwise be easy to miss.
191+
192+
For readable, executable examples of malformed payloads and the expected error messages across JSON, XML, YAML, and KeyValue, see [`tests/CodecMapper.Tests/TaggedUnionErrorTests.fs`](../tests/CodecMapper.Tests/TaggedUnionErrorTests.fs).

‎src/CodecMapper/Schema.fs‎

Lines changed: 12 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -37,8 +37,8 @@ and SchemaField = {
3737
Schema: ISchema
3838
}
3939

40-
/// Captures one case inside an explicit tagged-union schema.
41-
and SchemaUnionCase = {
40+
/// Captures one tag inside an explicit tagged-union schema.
41+
and SchemaTaggedCase = {
4242
Name: string
4343
FieldType: System.Type option
4444
Schema: ISchema option
@@ -53,7 +53,7 @@ and SchemaDefinition =
5353
| List of ISchema
5454
| Array of ISchema
5555
| Option of ISchema
56-
| Union of discriminatorName: string * valueName: string * SchemaUnionCase[]
56+
| Union of discriminatorName: string * valueName: string * SchemaTaggedCase[]
5757
| Delay of (unit -> ISchema)
5858
| MissingAsNone of ISchema
5959
| MissingAsValue of obj * ISchema
@@ -344,12 +344,12 @@ module Schema =
344344
create (Delay(fun () -> factory () :> ISchema))
345345

346346
/// Represents one explicit case in a tagged-union schema.
347-
type UnionCase<'T> = {
348-
Untyped: SchemaUnionCase
347+
type TaggedCase<'T> = {
348+
Untyped: SchemaTaggedCase
349349
}
350350

351-
/// Creates a case with no payload.
352-
let inline case0 (name: string) (value: 'T) (matches: 'T -> bool) : UnionCase<'T> =
351+
/// Creates a tag with no payload.
352+
let inline tag (name: string) (value: 'T) (matches: 'T -> bool) : TaggedCase<'T> =
353353
{
354354
Untyped = {
355355
Name = name
@@ -362,13 +362,13 @@ module Schema =
362362
}
363363
}
364364

365-
/// Creates a case with one payload value.
366-
let inline case1
365+
/// Creates a tag with one payload value.
366+
let inline tagWith
367367
(name: string)
368368
(project: 'T -> 'Field option)
369369
(inject: 'Field -> 'T)
370370
(schema: Schema<'Field>)
371-
: UnionCase<'T> =
371+
: TaggedCase<'T> =
372372
{
373373
Untyped = {
374374
Name = name
@@ -389,11 +389,11 @@ module Schema =
389389
}
390390

391391
/// Builds an explicit tagged-union schema using default wire field names.
392-
let inline union (cases: UnionCase<'T> list) : Schema<'T> =
392+
let inline union (cases: TaggedCase<'T> list) : Schema<'T> =
393393
create (Union("case", "value", cases |> List.map _.Untyped |> List.toArray))
394394

395395
/// Builds an explicit tagged-union schema with custom wire field names.
396-
let inline unionNamed (discriminatorName: string) (valueName: string) (cases: UnionCase<'T> list) : Schema<'T> =
396+
let inline unionNamed (discriminatorName: string) (valueName: string) (cases: TaggedCase<'T> list) : Schema<'T> =
397397
create (Union(discriminatorName, valueName, cases |> List.map _.Untyped |> List.toArray))
398398

399399
/// Builds a schema for arbitrary JSON values.

‎tests/CodecMapper.CompatibilitySentinel/Sentinel.fs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -175,14 +175,14 @@ module Schemas =
175175
let rec recursiveNode : Schema<RecursiveNode> =
176176
Schema.delay (fun () ->
177177
Schema.union [
178-
Schema.case1
178+
Schema.tagWith
179179
"leaf"
180180
(function
181181
| Leaf value -> Some value
182182
| _ -> None)
183183
Leaf
184184
Schema.string
185-
Schema.case1
185+
Schema.tagWith
186186
"branch"
187187
(function
188188
| Branch value -> Some value

‎tests/CodecMapper.Tests/CodecMapper.Tests.fsproj‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
<ItemGroup>
99
<Compile Include="Common.fs" />
1010
<Compile Include="SchemaDslTests.fs" />
11+
<Compile Include="TaggedUnionErrorTests.fs" />
1112
<Compile Include="JsonParserTests.fs" />
1213
<Compile Include="OptionTests.fs" />
1314
<Compile Include="FieldPolicyTests.fs" />

‎tests/CodecMapper.Tests/JsonSchemaTests.fs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -63,8 +63,8 @@ let commonTypeSchema =
6363
let ``Authored tagged unions export deterministic discriminator schema`` () =
6464
let schema =
6565
Schema.union [
66-
Schema.case0 "none" None Option.isNone
67-
Schema.case1
66+
Schema.tag "none" None Option.isNone
67+
Schema.tagWith
6868
"some"
6969
id
7070
Some
@@ -83,14 +83,14 @@ let ``Recursive delayed unions export local defs and refs`` () =
8383
let rec nodeSchema : Schema<RecursiveNode> =
8484
Schema.delay (fun () ->
8585
Schema.union [
86-
Schema.case1
86+
Schema.tagWith
8787
"leaf"
8888
(function
8989
| Leaf value -> Some value
9090
| _ -> None)
9191
Leaf
9292
Schema.string
93-
Schema.case1
93+
Schema.tagWith
9494
"branch"
9595
(function
9696
| Branch value -> Some value

‎tests/CodecMapper.Tests/KeyValueTests.fs‎

Lines changed: 2 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -131,14 +131,14 @@ let ``KeyValue round-trips recursive tagged unions with flattened discriminator
131131
let rec nodeSchema : Schema<RecursiveNode> =
132132
Schema.delay (fun () ->
133133
Schema.union [
134-
Schema.case1
134+
Schema.tagWith
135135
"leaf"
136136
(function
137137
| Leaf value -> Some value
138138
| _ -> None)
139139
Leaf
140140
Schema.string
141-
Schema.case1
141+
Schema.tagWith
142142
"branch"
143143
(function
144144
| Branch value -> Some value
@@ -163,42 +163,3 @@ let ``KeyValue round-trips recursive tagged unions with flattened discriminator
163163

164164
test <@ encoded = expected @>
165165
test <@ decoded = value @>
166-
167-
[<Fact>]
168-
let ``KeyValue rejects unknown tagged union cases`` () =
169-
let schema =
170-
Schema.union [
171-
Schema.case0 "pending" None Option.isNone
172-
Schema.case1 "ready" id Some Schema.string
173-
]
174-
175-
let codec = KeyValue.compile schema
176-
177-
expectFailure "KeyValue decode error at $.case: Unknown union case 'broken'" (fun () ->
178-
KeyValue.deserialize codec (Map.ofList [ "case", "broken" ]))
179-
180-
[<Fact>]
181-
let ``KeyValue rejects missing payloads for payload cases`` () =
182-
let schema =
183-
Schema.union [
184-
Schema.case0 "pending" None Option.isNone
185-
Schema.case1 "ready" id Some Schema.string
186-
]
187-
188-
let codec = KeyValue.compile schema
189-
190-
expectFailure "KeyValue decode error at $.value: Missing required key 'value'" (fun () ->
191-
KeyValue.deserialize codec (Map.ofList [ "case", "ready" ]))
192-
193-
[<Fact>]
194-
let ``KeyValue rejects stray payload keys for payload-free cases`` () =
195-
let schema =
196-
Schema.union [
197-
Schema.case0 "pending" None Option.isNone
198-
Schema.case1 "ready" id Some Schema.string
199-
]
200-
201-
let codec = KeyValue.compile schema
202-
203-
expectFailure "KeyValue decode error at $.value: Union case 'pending' does not accept key 'value'" (fun () ->
204-
KeyValue.deserialize codec (Map.ofList [ "case", "pending"; "value", "unexpected" ]))

‎tests/CodecMapper.Tests/SchemaDslTests.fs‎

Lines changed: 2 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -274,14 +274,14 @@ let ``Recursive tagged union round-trips JSON XML and YAML`` () =
274274
let rec nodeSchema : Schema<RecursiveNode> =
275275
Schema.delay (fun () ->
276276
Schema.union [
277-
Schema.case1
277+
Schema.tagWith
278278
"leaf"
279279
(function
280280
| Leaf value -> Some value
281281
| _ -> None)
282282
Leaf
283283
Schema.string
284-
Schema.case1
284+
Schema.tagWith
285285
"branch"
286286
(function
287287
| Branch value -> Some value
@@ -307,45 +307,6 @@ let ``Recursive tagged union round-trips JSON XML and YAML`` () =
307307
test <@ Xml.deserialize xmlCodec xml = value @>
308308
test <@ Yaml.deserialize yamlCodec yaml = value @>
309309

310-
[<Fact>]
311-
let ``Tagged unions reject malformed discriminator and payload shapes across text formats`` () =
312-
let schema =
313-
Schema.union [
314-
Schema.case0 "pending" None Option.isNone
315-
Schema.case1 "ready" id Some Schema.string
316-
]
317-
318-
let jsonCodec = Json.compile schema
319-
let xmlCodec = Xml.compile schema
320-
let yamlCodec = Yaml.compile schema
321-
322-
expectFailure "Unknown union case 'broken'" (fun () ->
323-
Json.deserialize jsonCodec """{"case":"broken"}""")
324-
325-
expectFailure "Missing union payload 'value' for case 'ready'" (fun () ->
326-
Json.deserialize jsonCodec """{"case":"ready"}""")
327-
328-
expectFailure "Union case 'pending' does not accept payload 'value'" (fun () ->
329-
Json.deserialize jsonCodec """{"case":"pending","value":"unexpected"}""")
330-
331-
expectFailure "Unknown union case 'broken'" (fun () ->
332-
Xml.deserialize xmlCodec "<fsharpoption`1><case>broken</case></fsharpoption`1>")
333-
334-
expectFailure "Expected <value>" (fun () ->
335-
Xml.deserialize xmlCodec "<fsharpoption`1><case>ready</case></fsharpoption`1>")
336-
337-
expectFailure "Union case 'pending' does not accept a <value> element" (fun () ->
338-
Xml.deserialize xmlCodec "<fsharpoption`1><case>pending</case><value>unexpected</value></fsharpoption`1>")
339-
340-
expectFailure "Unknown union case 'broken'" (fun () ->
341-
Yaml.deserialize yamlCodec "case: broken")
342-
343-
expectFailure "Missing union payload 'value' for case 'ready'" (fun () ->
344-
Yaml.deserialize yamlCodec "case: ready")
345-
346-
expectFailure "Union case 'pending' does not accept payload 'value'" (fun () ->
347-
Yaml.deserialize yamlCodec "case: pending\nvalue: unexpected")
348-
349310
[<Fact>]
350311
let ``Pipeline DSL can use opened Schema module at file scope`` () =
351312
let addressSchema =

0 commit comments

Comments
 (0)