NorfairKing/autodocodec
1
1
Fork 0
mirror of https://github.com/NorfairKing/autodocodec.git synced 2024-10-05 19:37:41 +03:00
Code Issues Projects Releases Wiki Activity

Add Discriminated unions

Browse Source
This commit is contained in:
David Overton 2022-07-18 21:00:05 +10:00 committed by Tom Sydney Kerckhove
parent 7d527f73de
commit a06ee16d8d
52 changed files with 933 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
autodocodec-api-usage/LICENSE
View File

@ -1,6 +1,6 @@
MIT License
Copyright (c) 2021 Tom Sydney Kerckhove
Copyright (c) 2021-2022 Tom Sydney Kerckhove
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

16
autodocodec-api-usage/autodocodec-api-usage.cabal
View File

@ -11,7 +11,7 @@ homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues
author: Tom Sydney Kerckhove
maintainer: syd@cs-syd.eu
copyright: 2021 Tom Sydney Kerckhove
copyright: 2021-2022 Tom Sydney Kerckhove
license: MIT
license-file: LICENSE
build-type: Simple
@ -44,6 +44,7 @@ extra-source-files:
test_resources/json-schema/either-bool-text.json
test_resources/json-schema/either-either-bool-scientific-text.json
test_resources/json-schema/example.json
test_resources/json-schema/expression.json
test_resources/json-schema/fruit.json
test_resources/json-schema/int.json
test_resources/json-schema/int16.json
@ -68,6 +69,7 @@ extra-source-files:
test_resources/json-schema/set-text.json
test_resources/json-schema/string.json
test_resources/json-schema/text.json
test_resources/json-schema/these.json
test_resources/json-schema/time-of-day.json
test_resources/json-schema/utc-time.json
test_resources/json-schema/value.json
@ -85,12 +87,14 @@ extra-source-files:
test_resources/openapi-schema/day.json
test_resources/openapi-schema/declareSchemaRef/ainur.json
test_resources/openapi-schema/declareSchemaRef/example.json
test_resources/openapi-schema/declareSchemaRef/expression.json
test_resources/openapi-schema/declareSchemaRef/fruit.json
test_resources/openapi-schema/declareSchemaRef/legacy-object.json
test_resources/openapi-schema/declareSchemaRef/legacy-value.json
test_resources/openapi-schema/declareSchemaRef/mutually-recursive.json
test_resources/openapi-schema/declareSchemaRef/null.json
test_resources/openapi-schema/declareSchemaRef/recursive.json
test_resources/openapi-schema/declareSchemaRef/these.json
test_resources/openapi-schema/declareSchemaRef/very-comment.json
test_resources/openapi-schema/declareSchemaRef/via.json
test_resources/openapi-schema/declareSchemaRef/war.json
@ -98,6 +102,7 @@ extra-source-files:
test_resources/openapi-schema/either-bool-text.json
test_resources/openapi-schema/either-either-bool-scientific-text.json
test_resources/openapi-schema/example.json
test_resources/openapi-schema/expression.json
test_resources/openapi-schema/fruit.json
test_resources/openapi-schema/int.json
test_resources/openapi-schema/int16.json
@ -122,6 +127,7 @@ extra-source-files:
test_resources/openapi-schema/set-text.json
test_resources/openapi-schema/string.json
test_resources/openapi-schema/text.json
test_resources/openapi-schema/these.json
test_resources/openapi-schema/time-of-day.json
test_resources/openapi-schema/utc-time.json
test_resources/openapi-schema/value.json
@ -140,6 +146,7 @@ extra-source-files:
test_resources/show-codec/either-bool-text.txt
test_resources/show-codec/either-either-bool-scientific-text.txt
test_resources/show-codec/example.txt
test_resources/show-codec/expression.txt
test_resources/show-codec/fruit.txt
test_resources/show-codec/int.txt
test_resources/show-codec/int16.txt
@ -163,6 +170,7 @@ extra-source-files:
test_resources/show-codec/set-text.txt
test_resources/show-codec/string.txt
test_resources/show-codec/text.txt
test_resources/show-codec/these.txt
test_resources/show-codec/time-of-day.txt
test_resources/show-codec/utc-time.txt
test_resources/show-codec/value.txt
@ -183,6 +191,7 @@ extra-source-files:
test_resources/swagger-schema/either-bool-text.json
test_resources/swagger-schema/either-either-bool-scientific-text.json
test_resources/swagger-schema/example.json
test_resources/swagger-schema/expression.json
test_resources/swagger-schema/fruit.json
test_resources/swagger-schema/int.json
test_resources/swagger-schema/int16.json
@ -207,6 +216,7 @@ extra-source-files:
test_resources/swagger-schema/set-text.json
test_resources/swagger-schema/string.json
test_resources/swagger-schema/text.json
test_resources/swagger-schema/these.json
test_resources/swagger-schema/time-of-day.json
test_resources/swagger-schema/utc-time.json
test_resources/swagger-schema/value.json
@ -226,6 +236,7 @@ extra-source-files:
test_resources/yaml-schema/either-bool-text.txt
test_resources/yaml-schema/either-either-bool-scientific-text.txt
test_resources/yaml-schema/example.txt
test_resources/yaml-schema/expression.txt
test_resources/yaml-schema/fruit.txt
test_resources/yaml-schema/int.txt
test_resources/yaml-schema/int16.txt
@ -251,6 +262,7 @@ extra-source-files:
test_resources/yaml-schema/set-text.txt
test_resources/yaml-schema/string.txt
test_resources/yaml-schema/text.txt
test_resources/yaml-schema/these.txt
test_resources/yaml-schema/time-of-day.txt
test_resources/yaml-schema/utc-time.txt
test_resources/yaml-schema/value.txt
@ -278,7 +290,7 @@ library
build-depends:
QuickCheck
, aeson
, autodocodec
, autodocodec >=0.2.0.0
, autodocodec-openapi3
, autodocodec-schema
, autodocodec-swagger2

4
autodocodec-api-usage/package.yaml
View File

@ -4,7 +4,7 @@ github: "NorfairKing/autodocodec"
license: MIT
author: "Tom Sydney Kerckhove"
maintainer: "syd@cs-syd.eu"
copyright: "2021 Tom Sydney Kerckhove"
copyright: "2021-2022 Tom Sydney Kerckhove"
synopsis: Autodocodec api usage tests
extra-source-files:
@ -19,7 +19,7 @@ library:
dependencies:
- QuickCheck
- aeson
- autodocodec
- autodocodec >=0.2.0.0
- autodocodec-openapi3
- autodocodec-schema
- autodocodec-swagger2

89
autodocodec-api-usage/src/Autodocodec/Usage.hs
View File

@ -24,6 +24,7 @@ import Data.GenValidity
import Data.GenValidity.Aeson ()
import Data.GenValidity.Scientific ()
import Data.GenValidity.Text ()
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import Data.OpenApi (ToSchema)
import qualified Data.OpenApi as OpenAPI
@ -493,3 +494,91 @@ instance HasCodec MultilineDefault where
object "MultilineDefault" $
MultilineDefault
<$> optionalFieldWithDefault "value" (Via "foo" "bar") "a field with a multi-line default value" .= multilineDefaultValue
data These
= This Text
| That Int
| Both Text Int
deriving stock (Show, Eq, Generic)
deriving
( FromJSON,
ToJSON,
Swagger.ToSchema,
OpenAPI.ToSchema
)
via (Autodocodec These)
instance Validity These
instance NFData These
instance GenValid These where
genValid = genValidStructurallyWithoutExtraChecking
shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
instance HasCodec These where
codec =
object "These" $
discriminatedUnionCodec "type" enc dec
where
textFieldCodec = requiredField' "text"
intFieldCodec = requiredField' "int"
bothFieldsCodec = (,) <$> textFieldCodec .= fst <*> intFieldCodec .= snd
enc = \case
This s -> ("this", mapToEncoder s textFieldCodec)
That n -> ("that", mapToEncoder n intFieldCodec)
Both s n -> ("both", mapToEncoder (s, n) bothFieldsCodec)
dec =
HashMap.fromList
[ ("this", ("This", mapToDecoder This textFieldCodec)),
("that", ("That", mapToDecoder That intFieldCodec)),
("both", ("Both", mapToDecoder (uncurry Both) bothFieldsCodec))
]
data Expression
= LiteralExpression Int
| SumExpression Expression Expression
| ProductExpression Expression Expression
deriving stock (Show, Eq, Generic)
deriving
( FromJSON,
ToJSON,
Swagger.ToSchema,
OpenAPI.ToSchema
)
via (Autodocodec Expression)
instance Validity Expression
instance NFData Expression
instance GenValid Expression where
genValid = sized $ \size ->
if size > 0
then
oneof
[ LiteralExpression <$> genValid,
genSplit (pred size) >>= \(size0, size1) ->
SumExpression <$> resize size0 genValid <*> resize size1 genValid,
genSplit (pred size) >>= \(size0, size1) ->
ProductExpression <$> resize size0 genValid <*> resize size1 genValid
]
else LiteralExpression <$> genValid
shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
instance HasCodec Expression where
codec =
named "Expression" $ object "Expression" $ discriminatedUnionCodec "type" enc dec
where
valueFieldCodec = requiredField' "value"
lrFieldsCodec = (,) <$> requiredField' "left" .= fst <*> requiredField' "right" .= snd
enc = \case
LiteralExpression n -> ("literal", mapToEncoder n valueFieldCodec)
SumExpression l r -> ("sum", mapToEncoder (l, r) lrFieldsCodec)
ProductExpression l r -> ("product", mapToEncoder (l, r) lrFieldsCodec)
dec =
HashMap.fromList
[ ("literal", ("LiteralExpression", mapToDecoder LiteralExpression valueFieldCodec)),
("sum", ("SumExpression", mapToDecoder (uncurry SumExpression) lrFieldsCodec)),
("product", ("ProductExpression", mapToDecoder (uncurry ProductExpression) lrFieldsCodec))
]

2
autodocodec-api-usage/test/Autodocodec/Aeson/SchemaSpec.hs
View File

@ -78,6 +78,8 @@ spec = do
jsonSchemaSpec @LegacyObject "legacy-object"
jsonSchemaSpec @Ainur "ainur"
jsonSchemaSpec @War "war"
jsonSchemaSpec @These "these"
jsonSchemaSpec @Expression "expression"
describe "JSONSchema" $ do
genValidSpec @JSONSchema
xdescribe "does not hold because this property does not hold for Scientific values like -7.85483897507979979e17" $

2
autodocodec-api-usage/test/Autodocodec/AesonSpec.hs
View File

@ -95,6 +95,8 @@ spec = do
aesonCodecSpec @LegacyObject
aesonCodecSpec @Ainur
aesonCodecSpec @War
aesonCodecSpec @These
aesonCodecSpec @Expression
aesonCodecErrorSpec ::
forall a.

4
autodocodec-api-usage/test/Autodocodec/OpenAPISpec.hs
View File

@ -94,6 +94,10 @@ spec = do
openAPISchemaSpecViaDeclareSchemaRef @Ainur "ainur"
openAPISchemaSpec @War "war"
openAPISchemaSpecViaDeclareSchemaRef @War "war"
openAPISchemaSpec @These "these"
openAPISchemaSpecViaDeclareSchemaRef @These "these"
openAPISchemaSpec @Expression "expression"
openAPISchemaSpecViaDeclareSchemaRef @Expression "expression"
openAPISchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
openAPISchemaSpec filePath =

2
autodocodec-api-usage/test/Autodocodec/ShowSpec.hs
View File

@ -65,6 +65,8 @@ spec = do
showCodecSpec @LegacyObject "legacy-object"
showCodecSpec @Ainur "ainur"
showCodecSpec @War "war"
showCodecSpec @These "these"
showCodecSpec @Expression "expression"
showCodecSpec ::
forall a.

2
autodocodec-api-usage/test/Autodocodec/SwaggerSpec.hs
View File

@ -83,6 +83,8 @@ spec = do
swaggerSchemaSpec @LegacyObject "legacy-object"
swaggerSchemaSpec @Ainur "ainur"
swaggerSchemaSpec @War "war"
swaggerSchemaSpec @These "these"
swaggerSchemaSpec @Expression "expression"
swaggerSchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
swaggerSchemaSpec filePath =

2
autodocodec-api-usage/test/Autodocodec/Yaml/SchemaSpec.hs
View File

@ -69,6 +69,8 @@ spec = do
yamlSchemaSpec @LegacyObject "legacy-object"
yamlSchemaSpec @Ainur "ainur"
yamlSchemaSpec @War "war"
yamlSchemaSpec @These "these"
yamlSchemaSpec @Expression "expression"
yamlSchemaSpec @MultilineDefault "multiline-default"
yamlSchemaSpec ::

2
autodocodec-api-usage/test/Autodocodec/YamlSpec.hs
View File

@ -76,6 +76,8 @@ spec = do
yamlCodecSpec @LegacyObject
yamlCodecSpec @Ainur
yamlCodecSpec @War
yamlCodecSpec @These
yamlCodecSpec @Expression
yamlCodecSpec ::
forall a.

66
autodocodec-api-usage/test_resources/json-schema/expression.json Normal file
View File

@ -0,0 +1,66 @@
{
"$defs": {
"Expression": {
"$comment": "Expression",
"oneOf": [
{
"properties": {
"left": {
"$ref": "#/$defs/Expression"
},
"right": {
"$ref": "#/$defs/Expression"
},
"type": {
"const": "product"
}
},
"required": [
"type",
"right",
"left"
],
"type": "object"
},
{
"properties": {
"type": {
"const": "literal"
},
"value": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
}
},
"required": [
"type",
"value"
],
"type": "object"
},
{
"properties": {
"left": {
"$ref": "#/$defs/Expression"
},
"right": {
"$ref": "#/$defs/Expression"
},
"type": {
"const": "sum"
}
},
"required": [
"type",
"right",
"left"
],
"type": "object"
}
],
"type": "object"
}
},
"$ref": "#/$defs/Expression"
}

59
autodocodec-api-usage/test_resources/json-schema/these.json Normal file
View File

@ -0,0 +1,59 @@
{
"$comment": "These",
"oneOf": [
{
"properties": {
"text": {
"type": "string"
},
"type": {
"const": "this"
}
},
"required": [
"type",
"text"
],
"type": "object"
},
{
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"text": {
"type": "string"
},
"type": {
"const": "both"
}
},
"required": [
"type",
"int",
"text"
],
"type": "object"
},
{
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": {
"const": "that"
}
},
"required": [
"type",
"int"
],
"type": "object"
}
],
"type": "object"
}

92
autodocodec-api-usage/test_resources/openapi-schema/declareSchemaRef/expression.json Normal file
View File

@ -0,0 +1,92 @@
{
"definitions": {
"Expression": {
"discriminator": {
"mapping": {
"literal": "LiteralExpression",
"product": "ProductExpression",
"sum": "SumExpression"
},
"propertyName": "type"
},
"oneOf": [
{
"$ref": "#/components/schemas/ProductExpression"
},
{
"$ref": "#/components/schemas/LiteralExpression"
},
{
"$ref": "#/components/schemas/SumExpression"
}
]
},
"LiteralExpression": {
"properties": {
"type": {
"enum": [
"literal"
],
"type": "string"
},
"value": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
}
},
"required": [
"value",
"type"
],
"type": "object"
},
"ProductExpression": {
"properties": {
"left": {
"$ref": "#/components/schemas/Expression"
},
"right": {
"$ref": "#/components/schemas/Expression"
},
"type": {
"enum": [
"product"
],
"type": "string"
}
},
"required": [
"left",
"right",
"type"
],
"type": "object"
},
"SumExpression": {
"properties": {
"left": {
"$ref": "#/components/schemas/Expression"
},
"right": {
"$ref": "#/components/schemas/Expression"
},
"type": {
"enum": [
"sum"
],
"type": "string"
}
},
"required": [
"left",
"right",
"type"
],
"type": "object"
}
},
"reference": {
"$ref": "#/components/schemas/Expression"
}
}

90
autodocodec-api-usage/test_resources/openapi-schema/declareSchemaRef/these.json Normal file
View File

@ -0,0 +1,90 @@
{
"definitions": {
"Both": {
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"text": {
"type": "string"
},
"type": {
"enum": [
"both"
],
"type": "string"
}
},
"required": [
"text",
"int",
"type"
],
"type": "object"
},
"That": {
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": {
"enum": [
"that"
],
"type": "string"
}
},
"required": [
"int",
"type"
],
"type": "object"
},
"These": {
"discriminator": {
"mapping": {
"both": "Both",
"that": "That",
"this": "This"
},
"propertyName": "type"
},
"oneOf": [
{
"$ref": "#/components/schemas/This"
},
{
"$ref": "#/components/schemas/Both"
},
{
"$ref": "#/components/schemas/That"
}
]
},
"This": {
"properties": {
"text": {
"type": "string"
},
"type": {
"enum": [
"this"
],
"type": "string"
}
},
"required": [
"text",
"type"
],
"type": "object"
}
},
"reference": {
"$ref": "#/components/schemas/These"
}
}

97
autodocodec-api-usage/test_resources/openapi-schema/expression.json Normal file
View File

@ -0,0 +1,97 @@
{
"components": {
"schemas": {
"Expression": {
"discriminator": {
"mapping": {
"literal": "LiteralExpression",
"product": "ProductExpression",
"sum": "SumExpression"
},
"propertyName": "type"
},
"oneOf": [
{
"$ref": "#/components/schemas/ProductExpression"
},
{
"$ref": "#/components/schemas/LiteralExpression"
},
{
"$ref": "#/components/schemas/SumExpression"
}
]
},
"LiteralExpression": {
"properties": {
"type": {
"enum": [
"literal"
],
"type": "string"
},
"value": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
}
},
"required": [
"value",
"type"
],
"type": "object"
},
"ProductExpression": {
"properties": {
"left": {
"$ref": "#/components/schemas/Expression"
},
"right": {
"$ref": "#/components/schemas/Expression"
},
"type": {
"enum": [
"product"
],
"type": "string"
}
},
"required": [
"left",
"right",
"type"
],
"type": "object"
},
"SumExpression": {
"properties": {
"left": {
"$ref": "#/components/schemas/Expression"
},
"right": {
"$ref": "#/components/schemas/Expression"
},
"type": {
"enum": [
"sum"
],
"type": "string"
}
},
"required": [
"left",
"right",
"type"
],
"type": "object"
}
}
},
"info": {
"title": "",
"version": ""
},
"openapi": "3.0.0",
"paths": {}
}

95
autodocodec-api-usage/test_resources/openapi-schema/these.json Normal file
View File

@ -0,0 +1,95 @@
{
"components": {
"schemas": {
"Both": {
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"text": {
"type": "string"
},
"type": {
"enum": [
"both"
],
"type": "string"
}
},
"required": [
"text",
"int",
"type"
],
"type": "object"
},
"That": {
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": {
"enum": [
"that"
],
"type": "string"
}
},
"required": [
"int",
"type"
],
"type": "object"
},
"These": {
"discriminator": {
"mapping": {
"both": "Both",
"that": "That",
"this": "This"
},
"propertyName": "type"
},
"oneOf": [
{
"$ref": "#/components/schemas/This"
},
{
"$ref": "#/components/schemas/Both"
},
{
"$ref": "#/components/schemas/That"
}
]
},
"This": {
"properties": {
"text": {
"type": "string"
},
"type": {
"enum": [
"this"
],
"type": "string"
}
},
"required": [
"text",
"type"
],
"type": "object"
}
}
},
"info": {
"title": "",
"version": ""
},
"openapi": "3.0.0",
"paths": {}
}

1
autodocodec-api-usage/test_resources/show-codec/expression.txt Normal file
View File

@ -0,0 +1 @@
ReferenceCodec "Expression" (ObjectOfCodec (Just "Expression") (DiscriminatedUnionCodec "type" _ [("product", (BimapCodec _ _ (ApCodec (BimapCodec _ _ (RequiredKeyCodec "left" Nothing (ReferenceCodec "Expression"))) (BimapCodec _ _ (RequiredKeyCodec "right" Nothing (ReferenceCodec "Expression")))))), ("literal", (BimapCodec _ _ (RequiredKeyCodec "value" Nothing (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = -9.223372036854775808e18, numberBoundsUpper = 9.223372036854775807e18}))))))), ("sum", (BimapCodec _ _ (ApCodec (BimapCodec _ _ (RequiredKeyCodec "left" Nothing (ReferenceCodec "Expression"))) (BimapCodec _ _ (RequiredKeyCodec "right" Nothing (ReferenceCodec "Expression"))))))]))

1
autodocodec-api-usage/test_resources/show-codec/these.txt Normal file
View File

@ -0,0 +1 @@
ObjectOfCodec (Just "These") (DiscriminatedUnionCodec "type" _ [("this", (BimapCodec _ _ (RequiredKeyCodec "text" Nothing (StringCodec Nothing)))), ("both", (BimapCodec _ _ (ApCodec (BimapCodec _ _ (RequiredKeyCodec "text" Nothing (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "int" Nothing (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = -9.223372036854775808e18, numberBoundsUpper = 9.223372036854775807e18}))))))))), ("that", (BimapCodec _ _ (RequiredKeyCodec "int" Nothing (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = -9.223372036854775808e18, numberBoundsUpper = 9.223372036854775807e18})))))))])

32
autodocodec-api-usage/test_resources/swagger-schema/expression.json Normal file
View File

@ -0,0 +1,32 @@
{
"definitions": {
"Expression": {
"properties": {
"left": {
"$ref": "#/definitions/Expression"
},
"right": {
"$ref": "#/definitions/Expression"
},
"type": {
"type": "string"
},
"value": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
}
},
"required": [
"type"
],
"type": "object"
}
},
"info": {
"title": "",
"version": ""
},
"paths": {},
"swagger": "2.0"
}

29
autodocodec-api-usage/test_resources/swagger-schema/these.json Normal file
View File

@ -0,0 +1,29 @@
{
"definitions": {
"These": {
"properties": {
"int": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"text": {
"type": "string"
},
"type": {
"type": "string"
}
},
"required": [
"type"
],
"type": "object"
}
},
"info": {
"title": "",
"version": ""
},
"paths": {},
"swagger": "2.0"
}

20
autodocodec-api-usage/test_resources/yaml-schema/expression.txt Normal file
View File

@ -0,0 +1,20 @@
def: Expression
# Expression
# one of
[ left: # required
ref: Expression
right: # required
ref: Expression
type: # required
product
, value: # required
<number> # between -9223372036854775808 and 9223372036854775807
type: # required
literal
, left: # required
ref: Expression
right: # required
ref: Expression
type: # required
sum
]

17
autodocodec-api-usage/test_resources/yaml-schema/these.txt Normal file
View File

@ -0,0 +1,17 @@
# These
# one of
[ text: # required
<string>
type: # required
this
, text: # required
<string>
int: # required
<number> # between -9223372036854775808 and 9223372036854775807
type: # required
both
, int: # required
<number> # between -9223372036854775808 and 9223372036854775807
type: # required
that
]

6
autodocodec-openapi3/CHANGELOG.md
View File

@ -1,5 +1,11 @@
# Changelog
## [0.2.1.1] - 2022-07-21
### Added
* Support for the `discriminatedUnionCodec` for discriminated unions in `autodocodec-0.2.0.0`
## [0.2.1.0] - 2022-06-19
### Changed

2
autodocodec-openapi3/LICENSE
View File

@ -1,6 +1,6 @@
MIT License
Copyright (c) 2021 Tom Sydney Kerckhove
Copyright (c) 2021-2022 Tom Sydney Kerckhove
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

6
autodocodec-openapi3/autodocodec-openapi3.cabal
View File

@ -5,13 +5,13 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: autodocodec-openapi3
version: 0.2.1.0
version: 0.2.1.1
synopsis: Autodocodec interpreters for openapi3
homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues
author: Tom Sydney Kerckhove
maintainer: syd@cs-syd.eu
copyright: 2021 Tom Sydney Kerckhove
copyright: 2021-2022 Tom Sydney Kerckhove
license: MIT
license-file: LICENSE
build-type: Simple
@ -34,7 +34,7 @@ library
src
build-depends:
aeson
, autodocodec
, autodocodec >=0.2.0.0
, base >=4.7 && <5
, insert-ordered-containers
, lens

6
autodocodec-openapi3/package.yaml
View File

@ -1,10 +1,10 @@
name: autodocodec-openapi3
version: 0.2.1.0
version: 0.2.1.1
github: "NorfairKing/autodocodec"
license: MIT
author: "Tom Sydney Kerckhove"
maintainer: "syd@cs-syd.eu"
copyright: "2021 Tom Sydney Kerckhove"
copyright: "2021-2022 Tom Sydney Kerckhove"
synopsis: Autodocodec interpreters for openapi3
extra-source-files:
@ -18,7 +18,7 @@ library:
source-dirs: src
dependencies:
- aeson
- autodocodec
- autodocodec >= 0.2.0.0
- unordered-containers
- insert-ordered-containers
- lens

17
autodocodec-openapi3/src/Autodocodec/OpenAPI/Schema.hs
View File

@ -17,6 +17,7 @@ import Control.Monad.State.Lazy (StateT, evalStateT, runStateT)
import qualified Control.Monad.State.Lazy as State
import Control.Monad.Trans (lift)
import qualified Data.Aeson as Aeson
import qualified Data.Foldable as Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
@ -182,6 +183,22 @@ declareNamedSchemaVia c' Proxy = evalStateT (go c') mempty
u
(NamedSchema Nothing (combineObjectSchemas s1s))
(NamedSchema Nothing (combineObjectSchemas s2s))
DiscriminatedUnionCodec pn _ m -> do
let d =
Discriminator
{ _discriminatorPropertyName = pn,
_discriminatorMapping = InsOrdHashMap.fromHashMap $ fmap fst m
}
mkSchema dName (refName, oc) = do
s <- goObject $ oc *> (requiredFieldWith' pn (literalTextCodec dName) .= const dName)
declareSpecificSchemaRef (Just refName) $ combineObjectSchemas s
ss <- HashMap.traverseWithKey mkSchema m
pure
[ mempty
{ _schemaDiscriminator = Just d,
_schemaOneOf = Just $ Foldable.toList ss
}
]
ApCodec oc1 oc2 -> do
ss1 <- goObject oc1
ss2 <- goObject oc2

6
autodocodec-schema/CHANGELOG.md
View File

@ -1,5 +1,11 @@
# Changelog
## [0.1.0.2] - 2022-07-21
### Added
* Support for the `discriminatedUnionCodec` for discriminated unions in `autodocodec-0.2.0.0`
## [0.1.0.1] - 2022-04-26
### Added

2
autodocodec-schema/LICENSE
View File

@ -1,6 +1,6 @@
MIT License
Copyright (c) 2021 Tom Sydney Kerckhove
Copyright (c) 2021-2022 Tom Sydney Kerckhove
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

6
autodocodec-schema/autodocodec-schema.cabal
View File

@ -5,13 +5,13 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: autodocodec-schema
version: 0.1.0.1
version: 0.1.0.2
synopsis: Autodocodec interpreters for JSON Schema
homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues
author: Tom Sydney Kerckhove
maintainer: syd@cs-syd.eu
copyright: 2021 Tom Sydney Kerckhove
copyright: 2021-2022 Tom Sydney Kerckhove
license: MIT
license-file: LICENSE
build-type: Simple
@ -32,7 +32,7 @@ library
src
build-depends:
aeson
, autodocodec >=0.0.1.0
, autodocodec >=0.2.0.0
, base >=4.7 && <5
, containers
, mtl

6
autodocodec-schema/package.yaml
View File

@ -1,10 +1,10 @@
name: autodocodec-schema
version: 0.1.0.1
version: 0.1.0.2
github: "NorfairKing/autodocodec"
license: MIT
author: "Tom Sydney Kerckhove"
maintainer: "syd@cs-syd.eu"
copyright: "2021 Tom Sydney Kerckhove"
copyright: "2021-2022 Tom Sydney Kerckhove"
synopsis: Autodocodec interpreters for JSON Schema
extra-source-files:
@ -18,7 +18,7 @@ library:
source-dirs: src
dependencies:
- aeson
- autodocodec >=0.0.1.0
- autodocodec >=0.2.0.0
- containers
- mtl
- text

7
autodocodec-schema/src/Autodocodec/Schema.hs
View File

@ -384,6 +384,13 @@ jsonSchemaVia = (`evalState` S.empty) . go
pure $ case u of
DisjointUnion -> ObjectOneOfSchema (goObjectOneOf (os1 :| [os2]))
PossiblyJointUnion -> ObjectAnyOfSchema (goObjectAnyOf (os1 :| [os2]))
DiscriminatedUnionCodec pn _ m -> do
let mkSchema dName (_, oc) =
goObject $ oc *> (requiredFieldWith' pn (literalTextCodec dName) .= const dName)
ss <- HM.traverseWithKey mkSchema m
pure $ case NE.nonEmpty $ toList ss of
Nothing -> ObjectAnySchema
Just ss' -> ObjectOneOfSchema $ goObjectOneOf ss'
PureCodec _ -> pure ObjectAnySchema
ApCodec oc1 oc2 -> do
os1 <- goObject oc1

6
autodocodec-swagger2/CHANGELOG.md
View File

@ -1,5 +1,11 @@
# Changelog
## [0.0.1.1] - 2022-07-21
### Added
* Support for the `discriminatedUnionCodec` for discriminated unions in `autodocodec-0.2.0.0`
## [0.0.1.0] - 2021-11-19
### Added

2
autodocodec-swagger2/LICENSE
View File

@ -1,6 +1,6 @@
MIT License
Copyright (c) 2021 Tom Sydney Kerckhove
Copyright (c) 2021-2022 Tom Sydney Kerckhove
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

7
autodocodec-swagger2/autodocodec-swagger2.cabal
View File

@ -1,11 +1,11 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.5.
-- This file has been generated from package.yaml by hpack version 0.34.7.
--
-- see: https://github.com/sol/hpack
name: autodocodec-swagger2
version: 0.0.1.0
version: 0.0.1.1
synopsis: Autodocodec interpreters for swagger2
homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues
@ -34,10 +34,11 @@ library
src
build-depends:
aeson
, autodocodec >=0.0.1.0
, autodocodec >=0.2.0.0
, base >=4.7 && <5
, insert-ordered-containers
, scientific
, swagger2
, text
, unordered-containers
default-language: Haskell2010

5
autodocodec-swagger2/package.yaml
View File

@ -1,5 +1,5 @@
name: autodocodec-swagger2
version: 0.0.1.0
version: 0.0.1.1
github: "NorfairKing/autodocodec"
license: MIT
author: "Tom Sydney Kerckhove"
@ -18,8 +18,9 @@ library:
source-dirs: src
dependencies:
- aeson
- autodocodec >=0.0.1.0
- autodocodec >=0.2.0.0
- insert-ordered-containers
- scientific
- swagger2
- text
- unordered-containers

10
autodocodec-swagger2/src/Autodocodec/Swagger/Schema.hs
View File

@ -11,6 +11,8 @@ module Autodocodec.Swagger.Schema where
import Autodocodec
import Control.Monad
import Data.Foldable (toList)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.List
import Data.Proxy
@ -164,6 +166,14 @@ declareNamedSchemaVia c' Proxy = go c'
ss1 <- goObject oc1
ss2 <- goObject oc2
pure [combineSchemaOr u (combineObjectSchemas ss1) (combineObjectSchemas ss2)]
DiscriminatedUnionCodec pn _ m -> do
let mkSchema dName (_, oc) =
fmap combineObjectSchemas $ goObject $ oc *> (requiredFieldWith' pn textCodec .= const dName)
ss <- HashMap.traverseWithKey mkSchema m
let combined = case toList ss of
[] -> mempty
(s : ss') -> foldr (combineSchemaOr DisjointUnion) s ss'
pure [combined]
ApCodec oc1 oc2 -> do
ss1 <- goObject oc1
ss2 <- goObject oc2

6
autodocodec-yaml/CHANGELOG.md
View File

@ -1,5 +1,11 @@
# Changelog
## [0.2.0.2] - 2022-07-21
### Added
* Support for the `discriminatedUnionCodec` for discriminated unions in `autodocodec-0.2.0.0`
## [0.2.0.1] - 2022-04-28
### Changed

2
autodocodec-yaml/LICENSE
View File

@ -1,6 +1,6 @@
MIT License
Copyright (c) 2021 Tom Sydney Kerckhove
Copyright (c) 2021-2022 Tom Sydney Kerckhove
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

4
autodocodec-yaml/autodocodec-yaml.cabal
View File

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: autodocodec-yaml
version: 0.2.0.0
version: 0.2.0.2
synopsis: Autodocodec interpreters for yaml
homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues
@ -34,7 +34,7 @@ library
hs-source-dirs:
src
build-depends:
autodocodec
autodocodec >=0.2.0.0
, autodocodec-schema >=0.1.0.0
, base >=4.7 && <5
, bytestring

4
autodocodec-yaml/package.yaml
View File

@ -1,5 +1,5 @@
name: autodocodec-yaml
version: 0.2.0.0
version: 0.2.0.2
github: "NorfairKing/autodocodec"
license: MIT
author: "Tom Sydney Kerckhove"
@ -17,7 +17,7 @@ dependencies:
library:
source-dirs: src
dependencies:
- autodocodec
- autodocodec >= 0.2.0.0
- autodocodec-schema >=0.1.0.0
- bytestring
- containers

4
autodocodec-yaml/src/Autodocodec/Yaml/Encode.hs
View File

@ -64,6 +64,10 @@ toYamlVia = flip go
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
Left a1 -> goObject a1 c1
Right a2 -> goObject a2 c2
DiscriminatedUnionCodec propertyName m _ ->
case m a of
(discriminatorValue, c) ->
(propertyName, Yaml.string discriminatorValue) : goObject a c
PureCodec _ -> []
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2

6
autodocodec/CHANGELOG.md
View File

@ -1,5 +1,11 @@
# Changelog
## [0.2.0.0] - 2022-07-21
### Added
* `discriminatedUnionCodec` for discriminated unions
## [0.1.0.3] - 2022-07-14
### Changed

2
autodocodec/LICENSE
View File

@ -1,6 +1,6 @@
MIT License
Copyright (c) 2021 Tom Sydney Kerckhove
Copyright (c) 2021-2022 Tom Sydney Kerckhove
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal

2
autodocodec/autodocodec.cabal
View File

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: autodocodec
version: 0.1.0.3
version: 0.2.0.0
synopsis: Self-documenting encoder and decoder
homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues

2
autodocodec/package.yaml
View File

@ -1,5 +1,5 @@
name: autodocodec
version: 0.1.0.3
version: 0.2.0.0
github: "NorfairKing/autodocodec"
license: MIT
author: "Tom Sydney Kerckhove"

5
autodocodec/src/Autodocodec.hs
View File

@ -85,6 +85,11 @@ module Autodocodec
disjointEitherCodec,
possiblyJointEitherCodec,
-- **** Discriminated unions
mapToEncoder,
mapToDecoder,
discriminatedUnionCodec,
-- *** Mapping
dimapCodec,
bimapCodec,

8
autodocodec/src/Autodocodec/Aeson/Compat.hs
View File

@ -35,6 +35,14 @@ lookupKey :: Text -> HM.HashMap Text v -> Maybe v
lookupKey = HM.lookup
#endif
#if MIN_VERSION_aeson(2,0,0)
insert :: Key -> v -> KM.KeyMap v -> KM.KeyMap v
insert = KM.insert
#else
insert :: Text -> v -> HM.HashMap Text v -> HM.HashMap Text v
insert = HM.insert
#endif
#if MIN_VERSION_aeson(2,0,0)
fromList :: [(Key, v)] -> KM.KeyMap v
fromList = KM.fromList

7
autodocodec/src/Autodocodec/Aeson/Decode.hs
View File

@ -14,6 +14,7 @@ import Control.Monad
import Data.Aeson as JSON
import Data.Aeson.Types as JSON
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map (Map)
import qualified Data.Text as T
import Data.Vector (Vector)
@ -108,6 +109,12 @@ parseJSONContextVia codec_ context_ =
unwords ["Left: ", lErr],
unwords ["Right: ", rErr]
]
DiscriminatedUnionCodec propertyName _ m -> do
discriminatorValue <- (value :: JSON.Object) JSON..: Compat.toKey propertyName
case HashMap.lookup discriminatorValue m of
Nothing -> fail $ "Unexpected discriminator value: " <> T.unpack discriminatorValue
Just (_, c) ->
go value c
CommentCodec _ c -> go value c
ReferenceCodec _ c -> go value c
RequiredKeyCodec k c _ -> do

8
autodocodec/src/Autodocodec/Aeson/Encode.hs
View File

@ -64,6 +64,10 @@ toJSONVia = flip go
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
Left a1 -> goObject a1 c1
Right a2 -> goObject a2 c2
DiscriminatedUnionCodec propertyName mapping _ ->
case mapping a of
(discriminatorValue, c) ->
Compat.insert (Compat.toKey propertyName) (JSON.String discriminatorValue) $ goObject a c
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
-- | Implement 'JSON.toEncoding' via a type's codec.
@ -108,6 +112,10 @@ toEncodingVia = flip go
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
Left a1 -> goObject a1 c1
Right a2 -> goObject a2 c2
DiscriminatedUnionCodec propertyName mapping _ ->
case mapping a of
(discriminatorValue, c) ->
JSON.pair (Compat.toKey propertyName) (JSON.toEncoding discriminatorValue) <> goObject a c
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
instance HasCodec a => JSON.ToJSON (Autodocodec a) where

86
autodocodec/src/Autodocodec/Codec.hs
View File

@ -22,7 +22,9 @@ import qualified Data.Aeson.KeyMap as KM
#endif
import qualified Data.Aeson.Types as JSON
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Hashable
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
@ -35,6 +37,7 @@ import Data.Validity
import Data.Validity.Scientific ()
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Void
import GHC.Generics (Generic)
-- $setup
@ -156,6 +159,31 @@ data Codec context input output where
-- | Codec for the 'Right' side
Codec context input2 output2 ->
Codec context (Either input1 input2) (Either output1 output2)
-- | Encode/decode a discriminated union of objects
--
-- The type of object being encoded/decoded is discriminated by
-- a designated "discriminator" property on the object which takes a string value.
--
-- When encoding, the provided function is applied to the input to obtain a new encoder
-- for the input. The function 'mapToEncoder' is provided to assist with building these
-- encoders.
--
-- When decoding, the value of the discriminator property is looked up in the `HashMap`
-- to obtain a decoder for the output. The function `mapToDecoder' is provided
-- to assist with building these decoders. See examples in 'Usage.hs'.
--
-- The 'HashMap' is also used to generate schemas for the type.
-- In particular, for OpenAPI 3, it will generate a schema with a 'discriminator', as defined
-- by https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/
DiscriminatedUnionCodec ::
-- | propertyName to use for discrimination
Text ->
-- | how to encode the input
(input -> (Discriminator, ObjectCodec input ())) ->
-- | how to decode the output
-- The 'Text' field is the name to use for the object schema.
HashMap Discriminator (Text, ObjectCodec Void output) ->
ObjectCodec input output
-- | A comment codec
--
-- This is used to add implementation-irrelevant but human-relevant information.
@ -309,6 +337,10 @@ showCodecABit = ($ "") . (`evalState` S.empty) . go 0
EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec 11 value . showString " " . s) <$> go 11 c
BimapCodec _ _ c -> (\s -> showParen (d > 10) $ showString "BimapCodec _ _ " . s) <$> go 11 c
EitherCodec u c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . showsPrec 11 u . showString " " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2
DiscriminatedUnionCodec propertyName _ mapping -> do
cs <- traverse (\(n, (_, c)) -> (\s -> showParen True $ shows n . showString ", " . s) <$> go 11 c) $ HashMap.toList mapping
let csList = showString "[" . foldr (.) id (intersperse (showString ", ") cs) . showString "]"
pure $ showParen (d > 10) $ showString "DiscriminatedUnionCodec " . showsPrec 11 propertyName . showString " _ " . csList
CommentCodec comment c -> (\s -> showParen (d > 10) $ showString "CommentCodec " . showsPrec 11 comment . showString " " . s) <$> go 11 c
ReferenceCodec name c -> do
alreadySeen <- gets (S.member name)
@ -643,6 +675,60 @@ possiblyJointEitherCodec ::
Codec context (Either input1 input2) (Either output1 output2)
possiblyJointEitherCodec = EitherCodec PossiblyJointUnion
-- | Discriminator value used in 'DiscriminatedUnionCodec'
type Discriminator = Text
-- | Wrap up a value of type 'b' with its codec to produce
-- and encoder for 'a's that ignores its input and instead encodes
-- the value 'b'.
-- This is useful for building 'discriminatedUnionCodec's.
mapToEncoder :: b -> Codec context b any -> Codec context a ()
mapToEncoder b = dimapCodec (const ()) (const b)
-- | Map a codec for decoding 'b's into a decoder for 'a's.
-- This is useful for building 'discriminatedUnionCodec's.
mapToDecoder :: (b -> a) -> Codec context any b -> Codec context Void a
mapToDecoder f = dimapCodec f absurd
-- | Encode/decode a discriminated union of objects
--
-- The type of object being encoded/decoded is discriminated by
-- a designated "discriminator" property on the object which takes a string value.
--
-- When encoding, the provided function is applied to the input to obtain a new encoder
-- for the input. The function 'mapToEncoder' is provided to assist with building these
-- encoders. See examples in 'Usage.hs'.
--
-- When decoding, the value of the discriminator property is looked up in the `HashMap`
-- to obtain a decoder for the output. The function `mapToDecoder' is provided
-- to assist with building these decoders. See examples in 'Usage.hs'.
--
-- The 'HashMap' is also used to generate schemas for the type.
-- In particular, for OpenAPI 3, it will generate a schema with a 'discriminator', as defined
-- by https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'DiscriminatedUnionCodec'.
--
-- > discriminatedUnionCodec = 'DiscriminatedUnionCodec'
discriminatedUnionCodec ::
-- | propertyName
Text ->
-- | how to encode the input
--
-- Use 'mapToEncoder' to produce the 'ObjectCodec's.
(input -> (Discriminator, ObjectCodec input ())) ->
-- | how to decode the output
--
-- The 'Text' field is the name to use for the object schema.
--
-- Use 'mapToDecoder' to produce the 'ObjectCodec's.
HashMap Discriminator (Text, ObjectCodec Void output) ->
ObjectCodec input output
discriminatedUnionCodec = DiscriminatedUnionCodec
-- | Map a codec's input and output types.
--
-- This function allows you to have the parsing fail in a new way.