mirror of
https://github.com/NorfairKing/autodocodec.git
synced 2024-10-27 08:10:10 +03:00
Support disjoint unions
This commit is contained in:
parent
d269215812
commit
45a112f16e
@ -28,6 +28,7 @@ import Data.Maybe
|
|||||||
import qualified Data.OpenApi as OpenAPI
|
import qualified Data.OpenApi as OpenAPI
|
||||||
import qualified Data.Swagger as Swagger
|
import qualified Data.Swagger as Swagger
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Word
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
@ -341,3 +342,75 @@ instance HasCodec LegacyObject where
|
|||||||
requiredField "oldest" "oldest key"
|
requiredField "oldest" "oldest key"
|
||||||
]
|
]
|
||||||
.= legacyObjectWithHistory
|
.= legacyObjectWithHistory
|
||||||
|
|
||||||
|
data Ainur
|
||||||
|
= Valar !Text !Text
|
||||||
|
| Maiar !Text
|
||||||
|
deriving stock (Show, Eq, Generic)
|
||||||
|
deriving
|
||||||
|
( FromJSON,
|
||||||
|
ToJSON,
|
||||||
|
Swagger.ToSchema,
|
||||||
|
OpenAPI.ToSchema
|
||||||
|
)
|
||||||
|
via (Autodocodec Ainur)
|
||||||
|
|
||||||
|
instance Validity Ainur
|
||||||
|
|
||||||
|
instance NFData Ainur
|
||||||
|
|
||||||
|
instance GenValid Ainur where
|
||||||
|
genValid = genValidStructurallyWithoutExtraChecking
|
||||||
|
shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
|
||||||
|
|
||||||
|
instance HasCodec Ainur where
|
||||||
|
codec =
|
||||||
|
dimapCodec f g $
|
||||||
|
possiblyJointEitherCodec
|
||||||
|
( object "Valar" $
|
||||||
|
(,)
|
||||||
|
<$> requiredField "domain" "Domain which the Valar rules over" .= fst
|
||||||
|
<*> requiredField "name" "Name of the Valar" .= snd
|
||||||
|
)
|
||||||
|
(object "Maiar" $ requiredField "name" "Name of the Maiar")
|
||||||
|
where
|
||||||
|
f = \case
|
||||||
|
Left (domain, name) -> Valar domain name
|
||||||
|
Right name -> Maiar name
|
||||||
|
g = \case
|
||||||
|
Valar domain name -> Left (domain, name)
|
||||||
|
Maiar name -> Right name
|
||||||
|
|
||||||
|
data War
|
||||||
|
= WorldWar !Word8
|
||||||
|
| OtherWar !Text
|
||||||
|
deriving stock (Show, Eq, Generic)
|
||||||
|
deriving
|
||||||
|
( FromJSON,
|
||||||
|
ToJSON,
|
||||||
|
Swagger.ToSchema,
|
||||||
|
OpenAPI.ToSchema
|
||||||
|
)
|
||||||
|
via (Autodocodec War)
|
||||||
|
|
||||||
|
instance Validity War
|
||||||
|
|
||||||
|
instance NFData War
|
||||||
|
|
||||||
|
instance GenValid War where
|
||||||
|
genValid = genValidStructurallyWithoutExtraChecking
|
||||||
|
shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
|
||||||
|
|
||||||
|
instance HasCodec War where
|
||||||
|
codec =
|
||||||
|
dimapCodec f g $
|
||||||
|
disjointEitherCodec
|
||||||
|
(codec :: JSONCodec Word8)
|
||||||
|
(codec :: JSONCodec Text)
|
||||||
|
where
|
||||||
|
f = \case
|
||||||
|
Left w -> WorldWar w
|
||||||
|
Right t -> OtherWar t
|
||||||
|
g = \case
|
||||||
|
WorldWar w -> Left w
|
||||||
|
OtherWar t -> Right t
|
||||||
|
@ -75,20 +75,23 @@ spec = do
|
|||||||
jsonSchemaSpec @VeryComment "very-comment"
|
jsonSchemaSpec @VeryComment "very-comment"
|
||||||
jsonSchemaSpec @LegacyValue "legacy-value"
|
jsonSchemaSpec @LegacyValue "legacy-value"
|
||||||
jsonSchemaSpec @LegacyObject "legacy-object"
|
jsonSchemaSpec @LegacyObject "legacy-object"
|
||||||
|
jsonSchemaSpec @Ainur "ainur"
|
||||||
|
jsonSchemaSpec @War "war"
|
||||||
describe "JSONSchema" $ do
|
describe "JSONSchema" $ do
|
||||||
genValidSpec @JSONSchema
|
genValidSpec @JSONSchema
|
||||||
it "roundtrips through json and back" $
|
xdescribe "does not hold because this property does not hold for Scientific values like -7.85483897507979979e17" $
|
||||||
forAllValid $ \jsonSchema ->
|
it "roundtrips through json and back" $
|
||||||
-- We use the reencode version to survive the ordering change through map
|
forAllValid $ \jsonSchema ->
|
||||||
let encoded = JSON.encode (jsonSchema :: JSONSchema)
|
-- We use the reencode version to survive the ordering change through map
|
||||||
encodedCtx = unwords ["encoded: ", show encoded]
|
let encoded = JSON.encode (jsonSchema :: JSONSchema)
|
||||||
in context encodedCtx $ case JSON.eitherDecode encoded of
|
encodedCtx = unwords ["encoded: ", show encoded]
|
||||||
Left err -> expectationFailure err
|
in context encodedCtx $ case JSON.eitherDecode encoded of
|
||||||
Right decoded ->
|
Left err -> expectationFailure err
|
||||||
let decodedCtx = unwords ["decoded: ", show decoded]
|
Right decoded ->
|
||||||
in context decodedCtx $
|
let decodedCtx = unwords ["decoded: ", show decoded]
|
||||||
let encodedAgain = JSON.encode (decoded :: JSONSchema)
|
in context decodedCtx $
|
||||||
in encodedAgain `shouldBe` encoded
|
let encodedAgain = JSON.encode (decoded :: JSONSchema)
|
||||||
|
in encodedAgain `shouldBe` encoded
|
||||||
describe "ObjectSchema" $ do
|
describe "ObjectSchema" $ do
|
||||||
genValidSpec @ObjectSchema
|
genValidSpec @ObjectSchema
|
||||||
it "roundtrips through object and back" $
|
it "roundtrips through object and back" $
|
||||||
@ -115,9 +118,10 @@ instance GenValid JSONSchema where
|
|||||||
ArraySchema s -> AnySchema : s : (ArraySchema <$> shrinkValid s)
|
ArraySchema s -> AnySchema : s : (ArraySchema <$> shrinkValid s)
|
||||||
ObjectSchema os -> AnySchema : (ObjectSchema <$> shrinkValid os)
|
ObjectSchema os -> AnySchema : (ObjectSchema <$> shrinkValid os)
|
||||||
ValueSchema v -> AnySchema : (ValueSchema <$> shrinkValid v)
|
ValueSchema v -> AnySchema : (ValueSchema <$> shrinkValid v)
|
||||||
ChoiceSchema ss -> case ss of
|
AnyOfSchema ss -> case ss of
|
||||||
s :| [] -> [s]
|
s :| _ -> s : filter isValid (AnyOfSchema <$> shrinkValid ss)
|
||||||
_ -> ChoiceSchema <$> shrinkValid ss
|
OneOfSchema ss -> case ss of
|
||||||
|
s :| _ -> s : filter isValid (OneOfSchema <$> shrinkValid ss)
|
||||||
CommentSchema k s -> (s :) $ do
|
CommentSchema k s -> (s :) $ do
|
||||||
(k', s') <- shrinkValid (k, s)
|
(k', s') <- shrinkValid (k, s)
|
||||||
pure $ CommentSchema k' s'
|
pure $ CommentSchema k' s'
|
||||||
@ -141,7 +145,15 @@ instance GenValid JSONSchema where
|
|||||||
choice2 <- resize b genValid
|
choice2 <- resize b genValid
|
||||||
rest <- resize c genValid
|
rest <- resize c genValid
|
||||||
pure $
|
pure $
|
||||||
ChoiceSchema $
|
AnyOfSchema $
|
||||||
|
choice1 :| (choice2 : rest),
|
||||||
|
do
|
||||||
|
(a, b, c) <- genSplit3 (n -1)
|
||||||
|
choice1 <- resize a genValid
|
||||||
|
choice2 <- resize b genValid
|
||||||
|
rest <- resize c genValid
|
||||||
|
pure $
|
||||||
|
OneOfSchema $
|
||||||
choice1 :| (choice2 : rest),
|
choice1 :| (choice2 : rest),
|
||||||
do
|
do
|
||||||
(a, b) <- genSplit (n -1)
|
(a, b) <- genSplit (n -1)
|
||||||
@ -155,7 +167,8 @@ instance GenValid JSONSchema where
|
|||||||
instance GenValid ObjectSchema where
|
instance GenValid ObjectSchema where
|
||||||
shrinkValid os = case os of
|
shrinkValid os = case os of
|
||||||
ObjectAnySchema -> []
|
ObjectAnySchema -> []
|
||||||
ObjectChoiceSchema ne@(s :| _) -> s : (ObjectChoiceSchema <$> shrinkValid ne)
|
ObjectAnyOfSchema ne@(s :| _) -> s : (ObjectAnyOfSchema <$> shrinkValid ne)
|
||||||
|
ObjectOneOfSchema ne@(s :| _) -> s : (ObjectOneOfSchema <$> shrinkValid ne)
|
||||||
ObjectAllOfSchema ne@(s :| _) -> s : (ObjectAllOfSchema <$> shrinkValid ne)
|
ObjectAllOfSchema ne@(s :| _) -> s : (ObjectAllOfSchema <$> shrinkValid ne)
|
||||||
_ -> shrinkValidStructurallyWithoutExtraFiltering os
|
_ -> shrinkValidStructurallyWithoutExtraFiltering os
|
||||||
genValid = oneof [pure ObjectAnySchema, go]
|
genValid = oneof [pure ObjectAnySchema, go]
|
||||||
@ -163,7 +176,8 @@ instance GenValid ObjectSchema where
|
|||||||
go =
|
go =
|
||||||
oneof
|
oneof
|
||||||
[ ObjectKeySchema <$> genValid <*> genValid <*> genValid <*> genValid,
|
[ ObjectKeySchema <$> genValid <*> genValid <*> genValid <*> genValid,
|
||||||
ObjectChoiceSchema <$> genValid,
|
ObjectAnyOfSchema <$> genValid,
|
||||||
|
ObjectOneOfSchema <$> genValid,
|
||||||
ObjectAllOfSchema <$> genValid
|
ObjectAllOfSchema <$> genValid
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -92,6 +92,8 @@ spec = do
|
|||||||
aesonCodecSpec @VeryComment
|
aesonCodecSpec @VeryComment
|
||||||
aesonCodecSpec @LegacyValue
|
aesonCodecSpec @LegacyValue
|
||||||
aesonCodecSpec @LegacyObject
|
aesonCodecSpec @LegacyObject
|
||||||
|
aesonCodecSpec @Ainur
|
||||||
|
aesonCodecSpec @War
|
||||||
|
|
||||||
aesonCodecErrorSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, HasCodec a) => FilePath -> LB.ByteString -> Spec
|
aesonCodecErrorSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, HasCodec a) => FilePath -> LB.ByteString -> Spec
|
||||||
aesonCodecErrorSpec filePath encoded =
|
aesonCodecErrorSpec filePath encoded =
|
||||||
|
@ -80,6 +80,8 @@ spec = do
|
|||||||
openAPISchemaSpec @VeryComment "very-comment"
|
openAPISchemaSpec @VeryComment "very-comment"
|
||||||
openAPISchemaSpec @LegacyValue "legacy-value"
|
openAPISchemaSpec @LegacyValue "legacy-value"
|
||||||
openAPISchemaSpec @LegacyObject "legacy-object"
|
openAPISchemaSpec @LegacyObject "legacy-object"
|
||||||
|
openAPISchemaSpec @Ainur "ainur"
|
||||||
|
openAPISchemaSpec @War "war"
|
||||||
|
|
||||||
openAPISchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
openAPISchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
||||||
openAPISchemaSpec filePath =
|
openAPISchemaSpec filePath =
|
||||||
|
@ -68,6 +68,8 @@ spec = do
|
|||||||
showCodecSpec @VeryComment "very-comment"
|
showCodecSpec @VeryComment "very-comment"
|
||||||
showCodecSpec @LegacyValue "legacy-value"
|
showCodecSpec @LegacyValue "legacy-value"
|
||||||
showCodecSpec @LegacyObject "legacy-object"
|
showCodecSpec @LegacyObject "legacy-object"
|
||||||
|
showCodecSpec @Ainur "ainur"
|
||||||
|
showCodecSpec @War "war"
|
||||||
|
|
||||||
showCodecSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
showCodecSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
||||||
showCodecSpec filePath =
|
showCodecSpec filePath =
|
||||||
|
@ -80,6 +80,8 @@ spec = do
|
|||||||
swaggerSchemaSpec @VeryComment "very-comment"
|
swaggerSchemaSpec @VeryComment "very-comment"
|
||||||
swaggerSchemaSpec @LegacyValue "legacy-value"
|
swaggerSchemaSpec @LegacyValue "legacy-value"
|
||||||
swaggerSchemaSpec @LegacyObject "legacy-object"
|
swaggerSchemaSpec @LegacyObject "legacy-object"
|
||||||
|
swaggerSchemaSpec @Ainur "ainur"
|
||||||
|
swaggerSchemaSpec @War "war"
|
||||||
|
|
||||||
swaggerSchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
swaggerSchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
||||||
swaggerSchemaSpec filePath =
|
swaggerSchemaSpec filePath =
|
||||||
|
@ -72,6 +72,8 @@ spec = do
|
|||||||
yamlSchemaSpec @VeryComment "very-comment"
|
yamlSchemaSpec @VeryComment "very-comment"
|
||||||
yamlSchemaSpec @LegacyValue "legacy-value"
|
yamlSchemaSpec @LegacyValue "legacy-value"
|
||||||
yamlSchemaSpec @LegacyObject "legacy-object"
|
yamlSchemaSpec @LegacyObject "legacy-object"
|
||||||
|
yamlSchemaSpec @Ainur "ainur"
|
||||||
|
yamlSchemaSpec @War "war"
|
||||||
|
|
||||||
yamlSchemaSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
yamlSchemaSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
|
||||||
yamlSchemaSpec filePath = do
|
yamlSchemaSpec filePath = do
|
||||||
|
@ -73,6 +73,8 @@ spec = do
|
|||||||
yamlCodecSpec @VeryComment
|
yamlCodecSpec @VeryComment
|
||||||
yamlCodecSpec @LegacyValue
|
yamlCodecSpec @LegacyValue
|
||||||
yamlCodecSpec @LegacyObject
|
yamlCodecSpec @LegacyObject
|
||||||
|
yamlCodecSpec @Ainur
|
||||||
|
yamlCodecSpec @War
|
||||||
|
|
||||||
yamlCodecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, FromJSON a, HasCodec a) => Spec
|
yamlCodecSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, ToJSON a, FromJSON a, HasCodec a) => Spec
|
||||||
yamlCodecSpec = describe (nameOf @a) $ do
|
yamlCodecSpec = describe (nameOf @a) $ do
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
Error in $:
|
Error in $:
|
||||||
Previous branch failure: Error in $: parsing HashMap ~Text failed, expected Object, but encountered Array
|
Both branches of a disjoint union failed:
|
||||||
parsing HashMap ~Text failed, expected Object, but encountered Array
|
Left: Error in $: parsing HashMap ~Text failed, expected Object, but encountered Array
|
||||||
|
Right: Error in $: parsing HashMap ~Text failed, expected Object, but encountered Array
|
||||||
|
35
autodocodec-api-usage/test_resources/json-schema/ainur.json
Normal file
35
autodocodec-api-usage/test_resources/json-schema/ainur.json
Normal file
@ -0,0 +1,35 @@
|
|||||||
|
{
|
||||||
|
"anyOf": [
|
||||||
|
{
|
||||||
|
"$comment": "Valar",
|
||||||
|
"required": [
|
||||||
|
"name",
|
||||||
|
"domain"
|
||||||
|
],
|
||||||
|
"type": "object",
|
||||||
|
"properties": {
|
||||||
|
"domain": {
|
||||||
|
"$comment": "Domain which the Valar rules over",
|
||||||
|
"type": "string"
|
||||||
|
},
|
||||||
|
"name": {
|
||||||
|
"$comment": "Name of the Valar",
|
||||||
|
"type": "string"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"$comment": "Maiar",
|
||||||
|
"required": [
|
||||||
|
"name"
|
||||||
|
],
|
||||||
|
"type": "object",
|
||||||
|
"properties": {
|
||||||
|
"name": {
|
||||||
|
"$comment": "Name of the Maiar",
|
||||||
|
"type": "string"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
@ -1,5 +1,5 @@
|
|||||||
{
|
{
|
||||||
"anyOf": [
|
"oneOf": [
|
||||||
{
|
{
|
||||||
"required": [
|
"required": [
|
||||||
"Left"
|
"Left"
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
{
|
{
|
||||||
"anyOf": [
|
"oneOf": [
|
||||||
{
|
{
|
||||||
"required": [
|
"required": [
|
||||||
"Left"
|
"Left"
|
||||||
@ -7,7 +7,7 @@
|
|||||||
"type": "object",
|
"type": "object",
|
||||||
"properties": {
|
"properties": {
|
||||||
"Left": {
|
"Left": {
|
||||||
"anyOf": [
|
"oneOf": [
|
||||||
{
|
{
|
||||||
"required": [
|
"required": [
|
||||||
"Left"
|
"Left"
|
||||||
|
12
autodocodec-api-usage/test_resources/json-schema/war.json
Normal file
12
autodocodec-api-usage/test_resources/json-schema/war.json
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
{
|
||||||
|
"oneOf": [
|
||||||
|
{
|
||||||
|
"maximum": 255,
|
||||||
|
"minimum": 0,
|
||||||
|
"type": "number"
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"type": "string"
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
@ -0,0 +1,52 @@
|
|||||||
|
{
|
||||||
|
"components": {
|
||||||
|
"schemas": {
|
||||||
|
"Ainur": {
|
||||||
|
"anyOf": [
|
||||||
|
{
|
||||||
|
"$ref": "#/components/schemas/Valar"
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"$ref": "#/components/schemas/Maiar"
|
||||||
|
}
|
||||||
|
],
|
||||||
|
"additionalProperties": true
|
||||||
|
},
|
||||||
|
"Valar": {
|
||||||
|
"required": [
|
||||||
|
"domain",
|
||||||
|
"name"
|
||||||
|
],
|
||||||
|
"type": "object",
|
||||||
|
"properties": {
|
||||||
|
"domain": {
|
||||||
|
"type": "string",
|
||||||
|
"description": "Domain which the Valar rules over"
|
||||||
|
},
|
||||||
|
"name": {
|
||||||
|
"type": "string",
|
||||||
|
"description": "Name of the Valar"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"Maiar": {
|
||||||
|
"required": [
|
||||||
|
"name"
|
||||||
|
],
|
||||||
|
"type": "object",
|
||||||
|
"properties": {
|
||||||
|
"name": {
|
||||||
|
"type": "string",
|
||||||
|
"description": "Name of the Maiar"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"openapi": "3.0.0",
|
||||||
|
"info": {
|
||||||
|
"version": "",
|
||||||
|
"title": ""
|
||||||
|
},
|
||||||
|
"paths": {}
|
||||||
|
}
|
@ -2,7 +2,7 @@
|
|||||||
"components": {
|
"components": {
|
||||||
"schemas": {
|
"schemas": {
|
||||||
"(Either Bool Text)": {
|
"(Either Bool Text)": {
|
||||||
"anyOf": [
|
"oneOf": [
|
||||||
{
|
{
|
||||||
"required": [
|
"required": [
|
||||||
"Left"
|
"Left"
|
||||||
@ -25,8 +25,7 @@
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
],
|
]
|
||||||
"additionalProperties": true
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
"components": {
|
"components": {
|
||||||
"schemas": {
|
"schemas": {
|
||||||
"(Either (Either Bool Scientific) Text)": {
|
"(Either (Either Bool Scientific) Text)": {
|
||||||
"anyOf": [
|
"oneOf": [
|
||||||
{
|
{
|
||||||
"required": [
|
"required": [
|
||||||
"Left"
|
"Left"
|
||||||
@ -10,7 +10,7 @@
|
|||||||
"type": "object",
|
"type": "object",
|
||||||
"properties": {
|
"properties": {
|
||||||
"Left": {
|
"Left": {
|
||||||
"anyOf": [
|
"oneOf": [
|
||||||
{
|
{
|
||||||
"required": [
|
"required": [
|
||||||
"Left"
|
"Left"
|
||||||
@ -33,8 +33,7 @@
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
],
|
]
|
||||||
"additionalProperties": true
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
@ -49,8 +48,7 @@
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
],
|
]
|
||||||
"additionalProperties": true
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
24
autodocodec-api-usage/test_resources/openapi-schema/war.json
Normal file
24
autodocodec-api-usage/test_resources/openapi-schema/war.json
Normal file
@ -0,0 +1,24 @@
|
|||||||
|
{
|
||||||
|
"components": {
|
||||||
|
"schemas": {
|
||||||
|
"War": {
|
||||||
|
"oneOf": [
|
||||||
|
{
|
||||||
|
"maximum": 255,
|
||||||
|
"minimum": 0,
|
||||||
|
"type": "number"
|
||||||
|
},
|
||||||
|
{
|
||||||
|
"type": "string"
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"openapi": "3.0.0",
|
||||||
|
"info": {
|
||||||
|
"version": "",
|
||||||
|
"title": ""
|
||||||
|
},
|
||||||
|
"paths": {}
|
||||||
|
}
|
@ -0,0 +1 @@
|
|||||||
|
BimapCodec _ _ (EitherCodec PossiblyJointUnion (ObjectOfCodec (Just "Valar") (ApCodec (BimapCodec _ _ (RequiredKeyCodec "domain" (Just "Domain which the Valar rules over") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "name" (Just "Name of the Valar") (StringCodec Nothing))))) (ObjectOfCodec (Just "Maiar") (RequiredKeyCodec "name" (Just "Name of the Maiar") (StringCodec Nothing))))
|
@ -1 +1 @@
|
|||||||
EitherCodec (ObjectOfCodec Nothing (RequiredKeyCodec "Left" Nothing (BoolCodec Nothing))) (ObjectOfCodec Nothing (RequiredKeyCodec "Right" Nothing (StringCodec Nothing)))
|
EitherCodec DisjointUnion (ObjectOfCodec Nothing (RequiredKeyCodec "Left" Nothing (BoolCodec Nothing))) (ObjectOfCodec Nothing (RequiredKeyCodec "Right" Nothing (StringCodec Nothing)))
|
@ -1 +1 @@
|
|||||||
EitherCodec (ObjectOfCodec Nothing (RequiredKeyCodec "Left" Nothing (EitherCodec (ObjectOfCodec Nothing (RequiredKeyCodec "Left" Nothing (BoolCodec Nothing))) (ObjectOfCodec Nothing (RequiredKeyCodec "Right" Nothing (NumberCodec Nothing Nothing)))))) (ObjectOfCodec Nothing (RequiredKeyCodec "Right" Nothing (StringCodec Nothing)))
|
EitherCodec DisjointUnion (ObjectOfCodec Nothing (RequiredKeyCodec "Left" Nothing (EitherCodec DisjointUnion (ObjectOfCodec Nothing (RequiredKeyCodec "Left" Nothing (BoolCodec Nothing))) (ObjectOfCodec Nothing (RequiredKeyCodec "Right" Nothing (NumberCodec Nothing Nothing)))))) (ObjectOfCodec Nothing (RequiredKeyCodec "Right" Nothing (StringCodec Nothing)))
|
@ -1 +1 @@
|
|||||||
ObjectOfCodec (Just "Example") (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (BimapCodec _ _ (RequiredKeyCodec "text" (Just "a text") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "bool" (Just "a bool") (BoolCodec Nothing)))) (BimapCodec _ _ (RequiredKeyCodec "maybe" (Just "a maybe text") (BimapCodec _ _ (EitherCodec NullCodec (StringCodec Nothing)))))) (BimapCodec _ _ (OptionalKeyCodec "optional" (Just "an optional text") (StringCodec Nothing)))) (BimapCodec _ _ (OptionalKeyCodec "optional-or-null" (Just "an optional-or-null text") (BimapCodec _ _ (EitherCodec NullCodec (StringCodec Nothing)))))) (BimapCodec _ _ (OptionalKeyWithDefaultCodec "optional-with-default" (StringCodec Nothing) _ (Just "an optional text with a default")))) (BimapCodec _ _ (OptionalKeyWithOmittedDefaultCodec "optional-with-null-default" (BimapCodec _ _ (ArrayOfCodec Nothing (StringCodec Nothing))) _ (Just "an optional list of texts with a default empty list where the empty list would be omitted")))) (BimapCodec _ _ (OptionalKeyWithOmittedDefaultCodec "single-or-list" (BimapCodec _ _ (EitherCodec (StringCodec Nothing) (BimapCodec _ _ (ArrayOfCodec Nothing (StringCodec Nothing))))) _ (Just "an optional list that can also be specified as a single element")))) (BimapCodec _ _ (RequiredKeyCodec "fruit" (Just "fruit!!") (BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "Apple" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "Orange" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "Banana" (StringCodec Nothing))) (BimapCodec _ _ (EqCodec "Melon" (StringCodec Nothing))))))))))))
|
ObjectOfCodec (Just "Example") (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (ApCodec (BimapCodec _ _ (RequiredKeyCodec "text" (Just "a text") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "bool" (Just "a bool") (BoolCodec Nothing)))) (BimapCodec _ _ (RequiredKeyCodec "maybe" (Just "a maybe text") (BimapCodec _ _ (EitherCodec PossiblyJointUnion NullCodec (StringCodec Nothing)))))) (BimapCodec _ _ (OptionalKeyCodec "optional" (Just "an optional text") (StringCodec Nothing)))) (BimapCodec _ _ (OptionalKeyCodec "optional-or-null" (Just "an optional-or-null text") (BimapCodec _ _ (EitherCodec PossiblyJointUnion NullCodec (StringCodec Nothing)))))) (BimapCodec _ _ (OptionalKeyWithDefaultCodec "optional-with-default" (StringCodec Nothing) _ (Just "an optional text with a default")))) (BimapCodec _ _ (OptionalKeyWithOmittedDefaultCodec "optional-with-null-default" (BimapCodec _ _ (ArrayOfCodec Nothing (StringCodec Nothing))) _ (Just "an optional list of texts with a default empty list where the empty list would be omitted")))) (BimapCodec _ _ (OptionalKeyWithOmittedDefaultCodec "single-or-list" (BimapCodec _ _ (EitherCodec PossiblyJointUnion (StringCodec Nothing) (BimapCodec _ _ (ArrayOfCodec Nothing (StringCodec Nothing))))) _ (Just "an optional list that can also be specified as a single element")))) (BimapCodec _ _ (RequiredKeyCodec "fruit" (Just "fruit!!") (BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "Apple" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "Orange" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "Banana" (StringCodec Nothing))) (BimapCodec _ _ (EqCodec "Melon" (StringCodec Nothing))))))))))))
|
@ -1 +1 @@
|
|||||||
BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "Apple" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "Orange" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "Banana" (StringCodec Nothing))) (BimapCodec _ _ (EqCodec "Melon" (StringCodec Nothing))))))))
|
BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "Apple" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "Orange" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "Banana" (StringCodec Nothing))) (BimapCodec _ _ (EqCodec "Melon" (StringCodec Nothing))))))))
|
@ -1 +1 @@
|
|||||||
ObjectOfCodec (Just "LegacyObject") (ApCodec (ApCodec (ApCodec (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "1" (Just "text 1") (StringCodec Nothing)) (RequiredKeyCodec "1old" (Just "text 1") (StringCodec Nothing)))) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "2" (Just "text 2") (StringCodec Nothing)) (RequiredKeyCodec "2old" (Just "text 2") (StringCodec Nothing))))) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "3" (Just "text 3") (StringCodec Nothing)) (RequiredKeyCodec "3old" (Just "text 3") (StringCodec Nothing))))) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "newest" (Just "newest key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "newer" (Just "newer key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "new" (Just "new key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "old" (Just "old key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec (RequiredKeyCodec "older" (Just "older key") (StringCodec Nothing)) (RequiredKeyCodec "oldest" (Just "oldest key") (StringCodec Nothing)))))))))))))
|
ObjectOfCodec (Just "LegacyObject") (ApCodec (ApCodec (ApCodec (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "1" (Just "text 1") (StringCodec Nothing)) (RequiredKeyCodec "1old" (Just "text 1") (StringCodec Nothing)))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "2" (Just "text 2") (StringCodec Nothing)) (RequiredKeyCodec "2old" (Just "text 2") (StringCodec Nothing))))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "3" (Just "text 3") (StringCodec Nothing)) (RequiredKeyCodec "3old" (Just "text 3") (StringCodec Nothing))))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "newest" (Just "newest key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "newer" (Just "newer key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "new" (Just "new key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "old" (Just "old key") (StringCodec Nothing)) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (RequiredKeyCodec "older" (Just "older key") (StringCodec Nothing)) (RequiredKeyCodec "oldest" (Just "oldest key") (StringCodec Nothing)))))))))))))
|
@ -1 +1 @@
|
|||||||
BimapCodec _ _ (EitherCodec (ObjectOfCodec (Just "LegacyValue") (ApCodec (ApCodec (BimapCodec _ _ (RequiredKeyCodec "1" (Just "text 1") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "2" (Just "text 2") (StringCodec Nothing)))) (BimapCodec _ _ (RequiredKeyCodec "3" (Just "text 3") (StringCodec Nothing))))) (ObjectOfCodec (Just "LegacyValue") (ApCodec (ApCodec (BimapCodec _ _ (RequiredKeyCodec "1old" (Just "text 1") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "2old" (Just "text 2") (StringCodec Nothing)))) (BimapCodec _ _ (RequiredKeyCodec "3old" (Just "text 3") (StringCodec Nothing))))))
|
BimapCodec _ _ (EitherCodec PossiblyJointUnion (ObjectOfCodec (Just "LegacyValue") (ApCodec (ApCodec (BimapCodec _ _ (RequiredKeyCodec "1" (Just "text 1") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "2" (Just "text 2") (StringCodec Nothing)))) (BimapCodec _ _ (RequiredKeyCodec "3" (Just "text 3") (StringCodec Nothing))))) (ObjectOfCodec (Just "LegacyValue") (ApCodec (ApCodec (BimapCodec _ _ (RequiredKeyCodec "1old" (Just "text 1") (StringCodec Nothing))) (BimapCodec _ _ (RequiredKeyCodec "2old" (Just "text 2") (StringCodec Nothing)))) (BimapCodec _ _ (RequiredKeyCodec "3old" (Just "text 3") (StringCodec Nothing))))))
|
@ -1 +1 @@
|
|||||||
BimapCodec _ _ (EitherCodec NullCodec (StringCodec Nothing))
|
BimapCodec _ _ (EitherCodec PossiblyJointUnion NullCodec (StringCodec Nothing))
|
@ -1 +1 @@
|
|||||||
BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "LT" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec (BimapCodec _ _ (EqCodec "EQ" (StringCodec Nothing))) (BimapCodec _ _ (EqCodec "GT" (StringCodec Nothing))))))
|
BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "LT" (StringCodec Nothing))) (BimapCodec _ _ (EitherCodec PossiblyJointUnion (BimapCodec _ _ (EqCodec "EQ" (StringCodec Nothing))) (BimapCodec _ _ (EqCodec "GT" (StringCodec Nothing))))))
|
@ -1 +1 @@
|
|||||||
ReferenceCodec "recursive" (BimapCodec _ _ (EitherCodec (CommentCodec "base case" (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = -9.223372036854775808e18, numberBoundsUpper = 9.223372036854775807e18}))))) (ObjectOfCodec (Just "Recurse") (RequiredKeyCodec "recurse" (Just "recursive case") (ReferenceCodec "recursive")))))
|
ReferenceCodec "recursive" (BimapCodec _ _ (EitherCodec PossiblyJointUnion (CommentCodec "base case" (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = -9.223372036854775808e18, numberBoundsUpper = 9.223372036854775807e18}))))) (ObjectOfCodec (Just "Recurse") (RequiredKeyCodec "recurse" (Just "recursive case") (ReferenceCodec "recursive")))))
|
1
autodocodec-api-usage/test_resources/show-codec/war.txt
Normal file
1
autodocodec-api-usage/test_resources/show-codec/war.txt
Normal file
@ -0,0 +1 @@
|
|||||||
|
BimapCodec _ _ (EitherCodec DisjointUnion (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = 0.0, numberBoundsUpper = 255.0})))) (StringCodec Nothing))
|
@ -0,0 +1,25 @@
|
|||||||
|
{
|
||||||
|
"swagger": "2.0",
|
||||||
|
"info": {
|
||||||
|
"version": "",
|
||||||
|
"title": ""
|
||||||
|
},
|
||||||
|
"definitions": {
|
||||||
|
"Ainur": {
|
||||||
|
"required": [
|
||||||
|
"name"
|
||||||
|
],
|
||||||
|
"type": "object",
|
||||||
|
"properties": {
|
||||||
|
"domain": {
|
||||||
|
"type": "string",
|
||||||
|
"description": "Domain which the Valar rules over"
|
||||||
|
},
|
||||||
|
"name": {
|
||||||
|
"type": "string",
|
||||||
|
"description": "Name of the Valar"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
10
autodocodec-api-usage/test_resources/swagger-schema/war.json
Normal file
10
autodocodec-api-usage/test_resources/swagger-schema/war.json
Normal file
@ -0,0 +1,10 @@
|
|||||||
|
{
|
||||||
|
"swagger": "2.0",
|
||||||
|
"info": {
|
||||||
|
"version": "",
|
||||||
|
"title": ""
|
||||||
|
},
|
||||||
|
"definitions": {
|
||||||
|
"War": {}
|
||||||
|
}
|
||||||
|
}
|
13
autodocodec-api-usage/test_resources/yaml-schema/ainur.txt
Normal file
13
autodocodec-api-usage/test_resources/yaml-schema/ainur.txt
Normal file
@ -0,0 +1,13 @@
|
|||||||
|
# [32many of[m
|
||||||
|
[ # Valar
|
||||||
|
[37mdomain[m: # [31mrequired[m
|
||||||
|
# Domain which the Valar rules over
|
||||||
|
[33m<string>[m
|
||||||
|
[37mname[m: # [31mrequired[m
|
||||||
|
# Name of the Valar
|
||||||
|
[33m<string>[m
|
||||||
|
, # Maiar
|
||||||
|
[37mname[m: # [31mrequired[m
|
||||||
|
# Name of the Maiar
|
||||||
|
[33m<string>[m
|
||||||
|
]
|
@ -1,3 +1,4 @@
|
|||||||
|
# [32mone of[m
|
||||||
[ [37mLeft[m: # [31mrequired[m
|
[ [37mLeft[m: # [31mrequired[m
|
||||||
[33m<boolean>[m
|
[33m<boolean>[m
|
||||||
, [37mRight[m: # [31mrequired[m
|
, [37mRight[m: # [31mrequired[m
|
||||||
|
@ -1,4 +1,6 @@
|
|||||||
|
# [32mone of[m
|
||||||
[ [37mLeft[m: # [31mrequired[m
|
[ [37mLeft[m: # [31mrequired[m
|
||||||
|
# [32mone of[m
|
||||||
[ [37mLeft[m: # [31mrequired[m
|
[ [37mLeft[m: # [31mrequired[m
|
||||||
[33m<boolean>[m
|
[33m<boolean>[m
|
||||||
, [37mRight[m: # [31mrequired[m
|
, [37mRight[m: # [31mrequired[m
|
||||||
|
@ -7,6 +7,7 @@
|
|||||||
[33m<boolean>[m
|
[33m<boolean>[m
|
||||||
[37mmaybe[m: # [31mrequired[m
|
[37mmaybe[m: # [31mrequired[m
|
||||||
# a maybe text
|
# a maybe text
|
||||||
|
# [32many of[m
|
||||||
[ [33mnull[m
|
[ [33mnull[m
|
||||||
, [33m<string>[m
|
, [33m<string>[m
|
||||||
]
|
]
|
||||||
@ -15,6 +16,7 @@
|
|||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
[37moptional-or-null[m: # [34moptional[m
|
[37moptional-or-null[m: # [34moptional[m
|
||||||
# an optional-or-null text
|
# an optional-or-null text
|
||||||
|
# [32many of[m
|
||||||
[ [33mnull[m
|
[ [33mnull[m
|
||||||
, [33m<string>[m
|
, [33m<string>[m
|
||||||
]
|
]
|
||||||
@ -29,11 +31,13 @@
|
|||||||
[37msingle-or-list[m: # [34moptional[m
|
[37msingle-or-list[m: # [34moptional[m
|
||||||
# default: [35m[][m
|
# default: [35m[][m
|
||||||
# an optional list that can also be specified as a single element
|
# an optional list that can also be specified as a single element
|
||||||
|
# [32many of[m
|
||||||
[ [33m<string>[m
|
[ [33m<string>[m
|
||||||
, - [33m<string>[m
|
, - [33m<string>[m
|
||||||
]
|
]
|
||||||
[37mfruit[m: # [31mrequired[m
|
[37mfruit[m: # [31mrequired[m
|
||||||
# fruit!!
|
# fruit!!
|
||||||
|
# [32many of[m
|
||||||
[ Apple
|
[ Apple
|
||||||
, Orange
|
, Orange
|
||||||
, Banana
|
, Banana
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
# [32many of[m
|
||||||
[ Apple
|
[ Apple
|
||||||
, Orange
|
, Orange
|
||||||
, Banana
|
, Banana
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
# LegacyObject
|
# LegacyObject
|
||||||
|
# [32many of[m
|
||||||
[ [37m1[m: # [31mrequired[m
|
[ [37m1[m: # [31mrequired[m
|
||||||
# text 1
|
# text 1
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
@ -6,6 +7,7 @@
|
|||||||
# text 1
|
# text 1
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
]
|
]
|
||||||
|
# [32many of[m
|
||||||
[ [37m2[m: # [31mrequired[m
|
[ [37m2[m: # [31mrequired[m
|
||||||
# text 2
|
# text 2
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
@ -13,6 +15,7 @@
|
|||||||
# text 2
|
# text 2
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
]
|
]
|
||||||
|
# [32many of[m
|
||||||
[ [37m3[m: # [31mrequired[m
|
[ [37m3[m: # [31mrequired[m
|
||||||
# text 3
|
# text 3
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
@ -20,6 +23,7 @@
|
|||||||
# text 3
|
# text 3
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
]
|
]
|
||||||
|
# [32many of[m
|
||||||
[ [37mnewest[m: # [31mrequired[m
|
[ [37mnewest[m: # [31mrequired[m
|
||||||
# newest key
|
# newest key
|
||||||
[33m<string>[m
|
[33m<string>[m
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
# [32many of[m
|
||||||
[ # LegacyValue
|
[ # LegacyValue
|
||||||
[37m1[m: # [31mrequired[m
|
[37m1[m: # [31mrequired[m
|
||||||
# text 1
|
# text 1
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
# [32many of[m
|
||||||
[ [33mnull[m
|
[ [33mnull[m
|
||||||
, [33m<string>[m
|
, [33m<string>[m
|
||||||
]
|
]
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
# [32many of[m
|
||||||
[ LT
|
[ LT
|
||||||
, EQ
|
, EQ
|
||||||
, GT
|
, GT
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
[36mdef: recursive[m
|
[36mdef: recursive[m
|
||||||
|
# [32many of[m
|
||||||
[ # base case
|
[ # base case
|
||||||
[33m<number>[m # between [32m-9223372036854775808[m and [32m9223372036854775807[m
|
[33m<number>[m # between [32m-9223372036854775808[m and [32m9223372036854775807[m
|
||||||
, # Recurse
|
, # Recurse
|
||||||
|
4
autodocodec-api-usage/test_resources/yaml-schema/war.txt
Normal file
4
autodocodec-api-usage/test_resources/yaml-schema/war.txt
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
# [32mone of[m
|
||||||
|
[ [33m<number>[m # between [32m0[m and [32m255[m
|
||||||
|
, [33m<string>[m
|
||||||
|
]
|
@ -1,5 +1,11 @@
|
|||||||
# Changelog
|
# Changelog
|
||||||
|
|
||||||
|
## [0.0.1.0] - 2021-12-23
|
||||||
|
|
||||||
|
### Added
|
||||||
|
|
||||||
|
* `disjointEitherCodec` now no longer generates `additionalProperties = true` and uses `oneOf` instead of `anyOf`.
|
||||||
|
|
||||||
## [0.0.0.0] - 2021-11-19
|
## [0.0.0.0] - 2021-11-19
|
||||||
|
|
||||||
First release.
|
First release.
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
-- This file has been generated from package.yaml by hpack version 0.34.5.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: autodocodec-openapi3
|
name: autodocodec-openapi3
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
synopsis: Autodocodec interpreters for openapi3
|
synopsis: Autodocodec interpreters for openapi3
|
||||||
homepage: https://github.com/NorfairKing/autodocodec#readme
|
homepage: https://github.com/NorfairKing/autodocodec#readme
|
||||||
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
||||||
@ -37,6 +37,7 @@ library
|
|||||||
, autodocodec
|
, autodocodec
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, insert-ordered-containers
|
, insert-ordered-containers
|
||||||
|
, lens
|
||||||
, openapi3
|
, openapi3
|
||||||
, scientific
|
, scientific
|
||||||
, text
|
, text
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
name: autodocodec-openapi3
|
name: autodocodec-openapi3
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
github: "NorfairKing/autodocodec"
|
github: "NorfairKing/autodocodec"
|
||||||
license: MIT
|
license: MIT
|
||||||
author: "Tom Sydney Kerckhove"
|
author: "Tom Sydney Kerckhove"
|
||||||
@ -20,6 +20,7 @@ library:
|
|||||||
- aeson
|
- aeson
|
||||||
- autodocodec
|
- autodocodec
|
||||||
- insert-ordered-containers
|
- insert-ordered-containers
|
||||||
- scientific
|
- lens
|
||||||
- openapi3
|
- openapi3
|
||||||
|
- scientific
|
||||||
- text
|
- text
|
||||||
|
@ -10,6 +10,7 @@
|
|||||||
module Autodocodec.OpenAPI.Schema where
|
module Autodocodec.OpenAPI.Schema where
|
||||||
|
|
||||||
import Autodocodec
|
import Autodocodec
|
||||||
|
import Control.Lens (Lens', (&), (?~), (^.))
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
|
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
|
||||||
import Data.OpenApi as OpenAPI
|
import Data.OpenApi as OpenAPI
|
||||||
@ -86,10 +87,10 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
ObjectOfCodec mname oc -> do
|
ObjectOfCodec mname oc -> do
|
||||||
ss <- goObject oc
|
ss <- goObject oc
|
||||||
pure $ NamedSchema mname $ combineObjectSchemas ss
|
pure $ NamedSchema mname $ combineObjectSchemas ss
|
||||||
EitherCodec c1 c2 -> do
|
EitherCodec u c1 c2 -> do
|
||||||
ns1 <- go c1
|
ns1 <- go c1
|
||||||
ns2 <- go c2
|
ns2 <- go c2
|
||||||
combineSchemasOr ns1 ns2
|
combineSchemasOr u ns1 ns2
|
||||||
CommentCodec t c -> do
|
CommentCodec t c -> do
|
||||||
NamedSchema mName s <- go c
|
NamedSchema mName s <- go c
|
||||||
pure $ NamedSchema mName $ addDoc t s
|
pure $ NamedSchema mName $ addDoc t s
|
||||||
@ -137,11 +138,12 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
]
|
]
|
||||||
OptionalKeyWithOmittedDefaultCodec key vs defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec key vs defaultValue mDoc)
|
OptionalKeyWithOmittedDefaultCodec key vs defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec key vs defaultValue mDoc)
|
||||||
PureCodec _ -> pure []
|
PureCodec _ -> pure []
|
||||||
EitherCodec oc1 oc2 -> do
|
EitherCodec u oc1 oc2 -> do
|
||||||
s1s <- goObject oc1
|
s1s <- goObject oc1
|
||||||
s2s <- goObject oc2
|
s2s <- goObject oc2
|
||||||
(: []) . _namedSchemaSchema
|
(: []) . _namedSchemaSchema
|
||||||
<$> combineSchemasOr
|
<$> combineSchemasOr
|
||||||
|
u
|
||||||
(NamedSchema Nothing (combineObjectSchemas s1s))
|
(NamedSchema Nothing (combineObjectSchemas s1s))
|
||||||
(NamedSchema Nothing (combineObjectSchemas s2s))
|
(NamedSchema Nothing (combineObjectSchemas s2s))
|
||||||
ApCodec oc1 oc2 -> do
|
ApCodec oc1 oc2 -> do
|
||||||
@ -160,19 +162,28 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
}
|
}
|
||||||
combineObjectSchemas :: [Schema] -> Schema
|
combineObjectSchemas :: [Schema] -> Schema
|
||||||
combineObjectSchemas = mconcat
|
combineObjectSchemas = mconcat
|
||||||
combineSchemasOr :: NamedSchema -> NamedSchema -> Declare (Definitions Schema) NamedSchema
|
combineSchemasOr :: Union -> NamedSchema -> NamedSchema -> Declare (Definitions Schema) NamedSchema
|
||||||
combineSchemasOr ns1 ns2 = do
|
combineSchemasOr u ns1 ns2 = do
|
||||||
let s1 = _namedSchemaSchema ns1
|
let s1 = _namedSchemaSchema ns1
|
||||||
let s2 = _namedSchemaSchema ns2
|
let s2 = _namedSchemaSchema ns2
|
||||||
s1Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns1
|
s1Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns1
|
||||||
s2Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns2
|
s2Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns2
|
||||||
let prototype = mempty {_schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True}
|
let orLens :: Lens' Schema (Maybe [Referenced Schema])
|
||||||
|
orLens = case u of
|
||||||
|
PossiblyJointUnion -> anyOf
|
||||||
|
DisjointUnion -> oneOf
|
||||||
|
let prototype =
|
||||||
|
mempty
|
||||||
|
{ _schemaAdditionalProperties = case u of
|
||||||
|
PossiblyJointUnion -> Just $ AdditionalPropertiesAllowed True
|
||||||
|
DisjointUnion -> Nothing
|
||||||
|
}
|
||||||
pure $
|
pure $
|
||||||
NamedSchema Nothing $ case (_schemaAnyOf s1, _schemaAnyOf s2) of
|
NamedSchema Nothing $ case (s1 ^. orLens, s2 ^. orLens) of
|
||||||
(Just s1s, Just s2s) -> prototype {_schemaAnyOf = Just $ s1s ++ s2s}
|
(Just s1s, Just s2s) -> prototype & orLens ?~ (s1s ++ s2s)
|
||||||
(Just s1s, Nothing) -> prototype {_schemaAnyOf = Just $ s1s ++ [s2Ref]}
|
(Just s1s, Nothing) -> prototype & orLens ?~ (s1s ++ [s2Ref])
|
||||||
(Nothing, Just s2s) -> prototype {_schemaAnyOf = Just $ s1Ref : s2s}
|
(Nothing, Just s2s) -> prototype & orLens ?~ (s1Ref : s2s)
|
||||||
(Nothing, Nothing) -> prototype {_schemaAnyOf = Just [s1Ref, s2Ref]}
|
(Nothing, Nothing) -> prototype & orLens ?~ [s1Ref, s2Ref]
|
||||||
|
|
||||||
declareSpecificNamedSchemaRef :: OpenAPI.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema)
|
declareSpecificNamedSchemaRef :: OpenAPI.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema)
|
||||||
declareSpecificNamedSchemaRef namedSchema =
|
declareSpecificNamedSchemaRef namedSchema =
|
||||||
|
@ -1,5 +1,15 @@
|
|||||||
# Changelog
|
# Changelog
|
||||||
|
|
||||||
|
## [0.1.0.0] - 2021-12-21
|
||||||
|
|
||||||
|
### Added
|
||||||
|
|
||||||
|
* Support for `autodocodec-0.0.1.0`.
|
||||||
|
|
||||||
|
### Changed
|
||||||
|
|
||||||
|
* `ChoiceSchema` has been split into `OneOfSchema` and `AnyOfSchema`
|
||||||
|
|
||||||
## [0.0.0.0] - 2021-11-19
|
## [0.0.0.0] - 2021-11-19
|
||||||
|
|
||||||
First release.
|
First release.
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
-- This file has been generated from package.yaml by hpack version 0.34.5.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: autodocodec-schema
|
name: autodocodec-schema
|
||||||
version: 0.0.0.0
|
version: 0.1.0.0
|
||||||
synopsis: Autodocodec interpreters for JSON Schema
|
synopsis: Autodocodec interpreters for JSON Schema
|
||||||
homepage: https://github.com/NorfairKing/autodocodec#readme
|
homepage: https://github.com/NorfairKing/autodocodec#readme
|
||||||
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
||||||
@ -32,7 +32,7 @@ library
|
|||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson
|
aeson
|
||||||
, autodocodec
|
, autodocodec >=0.0.1.0
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, containers
|
, containers
|
||||||
, mtl
|
, mtl
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
name: autodocodec-schema
|
name: autodocodec-schema
|
||||||
version: 0.0.0.0
|
version: 0.1.0.0
|
||||||
github: "NorfairKing/autodocodec"
|
github: "NorfairKing/autodocodec"
|
||||||
license: MIT
|
license: MIT
|
||||||
author: "Tom Sydney Kerckhove"
|
author: "Tom Sydney Kerckhove"
|
||||||
@ -18,7 +18,7 @@ library:
|
|||||||
source-dirs: src
|
source-dirs: src
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
- autodocodec
|
- autodocodec >=0.0.1.0
|
||||||
- containers
|
- containers
|
||||||
- mtl
|
- mtl
|
||||||
- text
|
- text
|
||||||
|
@ -48,7 +48,8 @@ data JSONSchema
|
|||||||
| -- | This needs to be a list because keys should stay in their original ordering.
|
| -- | This needs to be a list because keys should stay in their original ordering.
|
||||||
ObjectSchema ObjectSchema
|
ObjectSchema ObjectSchema
|
||||||
| ValueSchema !JSON.Value
|
| ValueSchema !JSON.Value
|
||||||
| ChoiceSchema !(NonEmpty JSONSchema)
|
| AnyOfSchema !(NonEmpty JSONSchema)
|
||||||
|
| OneOfSchema !(NonEmpty JSONSchema)
|
||||||
| CommentSchema !Text !JSONSchema
|
| CommentSchema !Text !JSONSchema
|
||||||
| RefSchema !Text
|
| RefSchema !Text
|
||||||
| WithDefSchema !(Map Text JSONSchema) !JSONSchema
|
| WithDefSchema !(Map Text JSONSchema) !JSONSchema
|
||||||
@ -62,7 +63,8 @@ instance Validity JSONSchema where
|
|||||||
CommentSchema _ (CommentSchema _ _) -> False
|
CommentSchema _ (CommentSchema _ _) -> False
|
||||||
_ -> True,
|
_ -> True,
|
||||||
case js of
|
case js of
|
||||||
ChoiceSchema cs -> declare "there are 2 of more choices" $ length cs >= 2
|
AnyOfSchema cs -> declare "there are 2 of more choices" $ length cs >= 2
|
||||||
|
OneOfSchema cs -> declare "there are 2 of more choices" $ length cs >= 2
|
||||||
_ -> valid
|
_ -> valid
|
||||||
]
|
]
|
||||||
|
|
||||||
@ -90,12 +92,18 @@ instance ToJSON JSONSchema where
|
|||||||
case toJSON os of
|
case toJSON os of
|
||||||
JSON.Object o -> HM.toList o
|
JSON.Object o -> HM.toList o
|
||||||
_ -> [] -- Should not happen.
|
_ -> [] -- Should not happen.
|
||||||
ChoiceSchema jcs ->
|
AnyOfSchema jcs ->
|
||||||
let svals :: [JSON.Value]
|
let svals :: [JSON.Value]
|
||||||
svals = map (JSON.object . go) (NE.toList jcs)
|
svals = map (JSON.object . go) (NE.toList jcs)
|
||||||
val :: JSON.Value
|
val :: JSON.Value
|
||||||
val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals
|
val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals
|
||||||
in [("anyOf", val)]
|
in [("anyOf", val)]
|
||||||
|
OneOfSchema jcs ->
|
||||||
|
let svals :: [JSON.Value]
|
||||||
|
svals = map (JSON.object . go) (NE.toList jcs)
|
||||||
|
val :: JSON.Value
|
||||||
|
val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals
|
||||||
|
in [("oneOf", val)]
|
||||||
(CommentSchema outerComment (CommentSchema innerComment s)) ->
|
(CommentSchema outerComment (CommentSchema innerComment s)) ->
|
||||||
go (CommentSchema (outerComment <> "\n" <> innerComment) s)
|
go (CommentSchema (outerComment <> "\n" <> innerComment) s)
|
||||||
CommentSchema comment s -> ("$comment" JSON..= comment) : go s
|
CommentSchema comment s -> ("$comment" JSON..= comment) : go s
|
||||||
@ -133,25 +141,30 @@ instance FromJSON JSONSchema where
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
mAny <- o JSON..:? "anyOf"
|
mAny <- o JSON..:? "anyOf"
|
||||||
case mAny of
|
case mAny of
|
||||||
Just anies -> pure $ ChoiceSchema anies
|
Just anies -> pure $ AnyOfSchema anies
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
let mConst = HM.lookup "const" o
|
mOne <- o JSON..:? "oneOf"
|
||||||
case mConst of
|
case mOne of
|
||||||
Just constant -> pure $ ValueSchema constant
|
Just ones -> pure $ OneOfSchema ones
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
mRef <- o JSON..:? "$ref"
|
let mConst = HM.lookup "const" o
|
||||||
pure $ case mRef of
|
case mConst of
|
||||||
Just ref -> case T.stripPrefix defsPrefix ref of
|
Just constant -> pure $ ValueSchema constant
|
||||||
Just name -> RefSchema name
|
Nothing -> do
|
||||||
Nothing -> AnySchema
|
mRef <- o JSON..:? "$ref"
|
||||||
Nothing -> AnySchema
|
pure $ case mRef of
|
||||||
|
Just ref -> case T.stripPrefix defsPrefix ref of
|
||||||
|
Just name -> RefSchema name
|
||||||
|
Nothing -> AnySchema
|
||||||
|
Nothing -> AnySchema
|
||||||
t -> fail $ "unknown schema type:" <> show t
|
t -> fail $ "unknown schema type:" <> show t
|
||||||
|
|
||||||
data ObjectSchema
|
data ObjectSchema
|
||||||
= ObjectKeySchema Text KeyRequirement JSONSchema (Maybe Text)
|
= ObjectKeySchema !Text !KeyRequirement !JSONSchema !(Maybe Text)
|
||||||
| ObjectAnySchema -- For 'pure'
|
| ObjectAnySchema -- For 'pure'
|
||||||
| ObjectChoiceSchema (NonEmpty ObjectSchema)
|
| ObjectAnyOfSchema !(NonEmpty ObjectSchema)
|
||||||
| ObjectAllOfSchema (NonEmpty ObjectSchema)
|
| ObjectOneOfSchema !(NonEmpty ObjectSchema)
|
||||||
|
| ObjectAllOfSchema !(NonEmpty ObjectSchema)
|
||||||
deriving (Show, Eq, Generic)
|
deriving (Show, Eq, Generic)
|
||||||
|
|
||||||
instance Validity ObjectSchema
|
instance Validity ObjectSchema
|
||||||
@ -171,26 +184,32 @@ instance FromJSON ObjectSchema where
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
mAnyOf <- o JSON..:? "anyOf"
|
mAnyOf <- o JSON..:? "anyOf"
|
||||||
case mAnyOf of
|
case mAnyOf of
|
||||||
Just ao -> do
|
Just anies -> do
|
||||||
ne <- parseJSON ao
|
ne <- parseJSON anies
|
||||||
ObjectChoiceSchema <$> mapM go ne
|
ObjectAnyOfSchema <$> mapM go ne
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
props <- o JSON..:? "properties" JSON..!= HM.empty
|
mOneOf <- o JSON..:? "oneOf"
|
||||||
reqs <- o JSON..:? "required" JSON..!= []
|
case mOneOf of
|
||||||
let keySchemaFor k v = do
|
Just ones -> do
|
||||||
ks <- parseJSON v
|
ne <- parseJSON ones
|
||||||
let (mDoc, ks') = case ks of
|
ObjectOneOfSchema <$> mapM go ne
|
||||||
CommentSchema doc ks'' -> (Just doc, ks'')
|
Nothing -> do
|
||||||
_ -> (Nothing, ks)
|
props <- o JSON..:? "properties" JSON..!= HM.empty
|
||||||
pure $
|
reqs <- o JSON..:? "required" JSON..!= []
|
||||||
if k `elem` reqs
|
let keySchemaFor k v = do
|
||||||
then ObjectKeySchema k Required ks' mDoc
|
ks <- parseJSON v
|
||||||
else ObjectKeySchema k (Optional Nothing) ks' mDoc
|
let (mDoc, ks') = case ks of
|
||||||
keySchemas <- mapM (uncurry keySchemaFor) (HM.toList props)
|
CommentSchema doc ks'' -> (Just doc, ks'')
|
||||||
pure $ case NE.nonEmpty keySchemas of
|
_ -> (Nothing, ks)
|
||||||
Nothing -> ObjectAnySchema
|
pure $
|
||||||
Just (el :| []) -> el
|
if k `elem` reqs
|
||||||
Just ne -> ObjectAllOfSchema ne
|
then ObjectKeySchema k Required ks' mDoc
|
||||||
|
else ObjectKeySchema k (Optional Nothing) ks' mDoc
|
||||||
|
keySchemas <- mapM (uncurry keySchemaFor) (HM.toList props)
|
||||||
|
pure $ case NE.nonEmpty keySchemas of
|
||||||
|
Nothing -> ObjectAnySchema
|
||||||
|
Just (el :| []) -> el
|
||||||
|
Just ne -> ObjectAllOfSchema ne
|
||||||
|
|
||||||
instance ToJSON ObjectSchema where
|
instance ToJSON ObjectSchema where
|
||||||
toJSON = JSON.object . (("type" JSON..= ("object" :: Text)) :) . go
|
toJSON = JSON.object . (("type" JSON..= ("object" :: Text)) :) . go
|
||||||
@ -202,7 +221,8 @@ instance ToJSON ObjectSchema where
|
|||||||
let (propVal, req) = keySchemaToPieces (k, kr, ks, mDoc)
|
let (propVal, req) = keySchemaToPieces (k, kr, ks, mDoc)
|
||||||
in -- TODO deal with the default value somehow.
|
in -- TODO deal with the default value somehow.
|
||||||
concat [["properties" JSON..= JSON.object [k JSON..= propVal]], ["required" JSON..= [k] | req]]
|
concat [["properties" JSON..= JSON.object [k JSON..= propVal]], ["required" JSON..= [k] | req]]
|
||||||
ObjectChoiceSchema ne -> ["anyOf" JSON..= NE.map toJSON ne]
|
ObjectAnyOfSchema ne -> ["anyOf" JSON..= NE.map toJSON ne]
|
||||||
|
ObjectOneOfSchema ne -> ["oneOf" JSON..= NE.map toJSON ne]
|
||||||
ObjectAllOfSchema ne ->
|
ObjectAllOfSchema ne ->
|
||||||
case mapM parseAndObjectKeySchema (NE.toList ne) of
|
case mapM parseAndObjectKeySchema (NE.toList ne) of
|
||||||
Nothing -> ["allOf" JSON..= NE.map toJSON ne]
|
Nothing -> ["allOf" JSON..= NE.map toJSON ne]
|
||||||
@ -239,7 +259,8 @@ validateAccordingTo val schema = (`evalState` M.empty) $ go val schema
|
|||||||
Optional _ -> pure True
|
Optional _ -> pure True
|
||||||
Just value' -> go value' ks
|
Just value' -> go value' ks
|
||||||
ObjectAllOfSchema ne -> and <$> mapM (goObject obj) ne
|
ObjectAllOfSchema ne -> and <$> mapM (goObject obj) ne
|
||||||
ObjectChoiceSchema ne -> or <$> mapM (goObject obj) ne
|
ObjectAnyOfSchema ne -> or <$> mapM (goObject obj) ne
|
||||||
|
ObjectOneOfSchema ne -> (== 1) . length . NE.filter id <$> mapM (goObject obj) ne
|
||||||
|
|
||||||
go :: JSON.Value -> JSONSchema -> State (Map Text JSONSchema) Bool
|
go :: JSON.Value -> JSONSchema -> State (Map Text JSONSchema) Bool
|
||||||
go value = \case
|
go value = \case
|
||||||
@ -266,7 +287,8 @@ validateAccordingTo val schema = (`evalState` M.empty) $ go val schema
|
|||||||
JSON.Object obj -> goObject obj os
|
JSON.Object obj -> goObject obj os
|
||||||
_ -> pure False
|
_ -> pure False
|
||||||
ValueSchema v -> pure $ v == value
|
ValueSchema v -> pure $ v == value
|
||||||
ChoiceSchema ss -> or <$> mapM (go value) ss
|
AnyOfSchema ss -> or <$> mapM (go value) ss
|
||||||
|
OneOfSchema ss -> (== 1) . length . NE.filter id <$> mapM (go value) ss
|
||||||
CommentSchema _ s -> go value s
|
CommentSchema _ s -> go value s
|
||||||
RefSchema name -> do
|
RefSchema name -> do
|
||||||
mSchema <- gets (M.lookup name)
|
mSchema <- gets (M.lookup name)
|
||||||
@ -279,7 +301,7 @@ validateAccordingTo val schema = (`evalState` M.empty) $ go val schema
|
|||||||
|
|
||||||
data KeyRequirement
|
data KeyRequirement
|
||||||
= Required
|
= Required
|
||||||
| Optional (Maybe JSON.Value) -- Default value
|
| Optional !(Maybe JSON.Value) -- Default value
|
||||||
deriving (Show, Eq, Generic)
|
deriving (Show, Eq, Generic)
|
||||||
|
|
||||||
instance Validity KeyRequirement
|
instance Validity KeyRequirement
|
||||||
@ -306,10 +328,12 @@ jsonSchemaVia = (`evalState` S.empty) . go
|
|||||||
MapCodec c -> MapSchema <$> go c
|
MapCodec c -> MapSchema <$> go c
|
||||||
ValueCodec -> pure AnySchema
|
ValueCodec -> pure AnySchema
|
||||||
EqCodec value c -> pure $ ValueSchema (toJSONVia c value)
|
EqCodec value c -> pure $ ValueSchema (toJSONVia c value)
|
||||||
EitherCodec c1 c2 -> do
|
EitherCodec u c1 c2 -> do
|
||||||
s1 <- go c1
|
s1 <- go c1
|
||||||
s2 <- go c2
|
s2 <- go c2
|
||||||
pure $ ChoiceSchema (goChoice (s1 :| [s2]))
|
pure $ case u of
|
||||||
|
DisjointUnion -> OneOfSchema (goOneOf (s1 :| [s2]))
|
||||||
|
PossiblyJointUnion -> AnyOfSchema (goAnyOf (s1 :| [s2]))
|
||||||
BimapCodec _ _ c -> go c
|
BimapCodec _ _ c -> go c
|
||||||
CommentCodec t c -> CommentSchema t <$> go c
|
CommentCodec t c -> CommentSchema t <$> go c
|
||||||
ReferenceCodec name c -> do
|
ReferenceCodec name c -> do
|
||||||
@ -321,14 +345,23 @@ jsonSchemaVia = (`evalState` S.empty) . go
|
|||||||
s <- go c
|
s <- go c
|
||||||
pure $ WithDefSchema (M.singleton name s) (RefSchema name)
|
pure $ WithDefSchema (M.singleton name s) (RefSchema name)
|
||||||
|
|
||||||
goChoice :: NonEmpty JSONSchema -> NonEmpty JSONSchema
|
goAnyOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
|
||||||
goChoice (s :| rest) = case NE.nonEmpty rest of
|
goAnyOf (s :| rest) = case NE.nonEmpty rest of
|
||||||
Nothing -> goSingle s
|
Nothing -> goSingle s
|
||||||
Just ne -> goSingle s <> goChoice ne
|
Just ne -> goSingle s <> goAnyOf ne
|
||||||
where
|
where
|
||||||
goSingle :: JSONSchema -> NonEmpty JSONSchema
|
goSingle :: JSONSchema -> NonEmpty JSONSchema
|
||||||
goSingle = \case
|
goSingle = \case
|
||||||
ChoiceSchema ss -> goChoice ss
|
AnyOfSchema ss -> goAnyOf ss
|
||||||
|
s' -> s' :| []
|
||||||
|
goOneOf :: NonEmpty JSONSchema -> NonEmpty JSONSchema
|
||||||
|
goOneOf (s :| rest) = case NE.nonEmpty rest of
|
||||||
|
Nothing -> goSingle s
|
||||||
|
Just ne -> goSingle s <> goOneOf ne
|
||||||
|
where
|
||||||
|
goSingle :: JSONSchema -> NonEmpty JSONSchema
|
||||||
|
goSingle = \case
|
||||||
|
OneOfSchema ss -> goOneOf ss
|
||||||
s' -> s' :| []
|
s' -> s' :| []
|
||||||
|
|
||||||
goObject :: ObjectCodec input output -> State (Set Text) ObjectSchema
|
goObject :: ObjectCodec input output -> State (Set Text) ObjectSchema
|
||||||
@ -344,24 +377,36 @@ jsonSchemaVia = (`evalState` S.empty) . go
|
|||||||
pure $ ObjectKeySchema k (Optional (Just (toJSONVia c mr))) s mdoc
|
pure $ ObjectKeySchema k (Optional (Just (toJSONVia c mr))) s mdoc
|
||||||
OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
||||||
BimapCodec _ _ c -> goObject c
|
BimapCodec _ _ c -> goObject c
|
||||||
EitherCodec oc1 oc2 -> do
|
EitherCodec u oc1 oc2 -> do
|
||||||
os1 <- goObject oc1
|
os1 <- goObject oc1
|
||||||
os2 <- goObject oc2
|
os2 <- goObject oc2
|
||||||
pure $ ObjectChoiceSchema (goObjectChoice (os1 :| [os2]))
|
pure $ case u of
|
||||||
|
DisjointUnion -> ObjectOneOfSchema (goObjectOneOf (os1 :| [os2]))
|
||||||
|
PossiblyJointUnion -> ObjectAnyOfSchema (goObjectAnyOf (os1 :| [os2]))
|
||||||
PureCodec _ -> pure ObjectAnySchema
|
PureCodec _ -> pure ObjectAnySchema
|
||||||
ApCodec oc1 oc2 -> do
|
ApCodec oc1 oc2 -> do
|
||||||
os1 <- goObject oc1
|
os1 <- goObject oc1
|
||||||
os2 <- goObject oc2
|
os2 <- goObject oc2
|
||||||
pure $ ObjectAllOfSchema (goObjectAllOf (os1 :| [os2]))
|
pure $ ObjectAllOfSchema (goObjectAllOf (os1 :| [os2]))
|
||||||
|
|
||||||
goObjectChoice :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
|
goObjectAnyOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
|
||||||
goObjectChoice (s :| rest) = case NE.nonEmpty rest of
|
goObjectAnyOf (s :| rest) = case NE.nonEmpty rest of
|
||||||
Nothing -> goSingle s
|
Nothing -> goSingle s
|
||||||
Just ne -> goSingle s <> goObjectChoice ne
|
Just ne -> goSingle s <> goObjectAnyOf ne
|
||||||
where
|
where
|
||||||
goSingle :: ObjectSchema -> NonEmpty ObjectSchema
|
goSingle :: ObjectSchema -> NonEmpty ObjectSchema
|
||||||
goSingle = \case
|
goSingle = \case
|
||||||
ObjectChoiceSchema ss -> goObjectChoice ss
|
ObjectAnyOfSchema ss -> goObjectAnyOf ss
|
||||||
|
s' -> s' :| []
|
||||||
|
|
||||||
|
goObjectOneOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
|
||||||
|
goObjectOneOf (s :| rest) = case NE.nonEmpty rest of
|
||||||
|
Nothing -> goSingle s
|
||||||
|
Just ne -> goSingle s <> goObjectOneOf ne
|
||||||
|
where
|
||||||
|
goSingle :: ObjectSchema -> NonEmpty ObjectSchema
|
||||||
|
goSingle = \case
|
||||||
|
ObjectOneOfSchema ss -> goObjectOneOf ss
|
||||||
s' -> s' :| []
|
s' -> s' :| []
|
||||||
|
|
||||||
goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
|
goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema
|
||||||
|
@ -1,5 +1,11 @@
|
|||||||
# Changelog
|
# Changelog
|
||||||
|
|
||||||
|
## [0.0.1.0] - 2021-11-19
|
||||||
|
|
||||||
|
### Added
|
||||||
|
|
||||||
|
* `disjointEitherCodec` now does not generate `additionalProperties = true`.
|
||||||
|
|
||||||
## [0.0.0.0] - 2021-11-19
|
## [0.0.0.0] - 2021-11-19
|
||||||
|
|
||||||
First release.
|
First release.
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
-- This file has been generated from package.yaml by hpack version 0.34.5.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: autodocodec-swagger2
|
name: autodocodec-swagger2
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
synopsis: Autodocodec interpreters for swagger2
|
synopsis: Autodocodec interpreters for swagger2
|
||||||
homepage: https://github.com/NorfairKing/autodocodec#readme
|
homepage: https://github.com/NorfairKing/autodocodec#readme
|
||||||
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
||||||
@ -34,7 +34,7 @@ library
|
|||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson
|
aeson
|
||||||
, autodocodec
|
, autodocodec >=0.0.1.0
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, insert-ordered-containers
|
, insert-ordered-containers
|
||||||
, scientific
|
, scientific
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
name: autodocodec-swagger2
|
name: autodocodec-swagger2
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
github: "NorfairKing/autodocodec"
|
github: "NorfairKing/autodocodec"
|
||||||
license: MIT
|
license: MIT
|
||||||
author: "Tom Sydney Kerckhove"
|
author: "Tom Sydney Kerckhove"
|
||||||
@ -18,7 +18,7 @@ library:
|
|||||||
source-dirs: src
|
source-dirs: src
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
- autodocodec
|
- autodocodec >=0.0.1.0
|
||||||
- insert-ordered-containers
|
- insert-ordered-containers
|
||||||
- scientific
|
- scientific
|
||||||
- swagger2
|
- swagger2
|
||||||
|
@ -104,12 +104,12 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
{ _schemaParamSchema = mempty {_paramSchemaEnum = Just [toJSONVia valCodec val]}
|
{ _schemaParamSchema = mempty {_paramSchemaEnum = Just [toJSONVia valCodec val]}
|
||||||
}
|
}
|
||||||
BimapCodec _ _ c -> go c
|
BimapCodec _ _ c -> go c
|
||||||
EitherCodec c1 c2 -> do
|
EitherCodec u c1 c2 -> do
|
||||||
ns1 <- go c1
|
ns1 <- go c1
|
||||||
let s1 = _namedSchemaSchema ns1
|
let s1 = _namedSchemaSchema ns1
|
||||||
ns2 <- go c2
|
ns2 <- go c2
|
||||||
let s2 = _namedSchemaSchema ns2
|
let s2 = _namedSchemaSchema ns2
|
||||||
pure $ NamedSchema Nothing $ combineSchemaOr s1 s2
|
pure $ NamedSchema Nothing $ combineSchemaOr u s1 s2
|
||||||
CommentCodec t c -> do
|
CommentCodec t c -> do
|
||||||
NamedSchema mName s <- go c
|
NamedSchema mName s <- go c
|
||||||
pure $ NamedSchema mName $ addDoc t s
|
pure $ NamedSchema mName $ addDoc t s
|
||||||
@ -160,10 +160,10 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
]
|
]
|
||||||
OptionalKeyWithOmittedDefaultCodec key vs defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec key vs defaultValue mDoc)
|
OptionalKeyWithOmittedDefaultCodec key vs defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec key vs defaultValue mDoc)
|
||||||
PureCodec _ -> pure []
|
PureCodec _ -> pure []
|
||||||
EitherCodec oc1 oc2 -> do
|
EitherCodec u oc1 oc2 -> do
|
||||||
ss1 <- goObject oc1
|
ss1 <- goObject oc1
|
||||||
ss2 <- goObject oc2
|
ss2 <- goObject oc2
|
||||||
pure [combineSchemaOr (combineObjectSchemas ss1) (combineObjectSchemas ss2)]
|
pure [combineSchemaOr u (combineObjectSchemas ss1) (combineObjectSchemas ss2)]
|
||||||
ApCodec oc1 oc2 -> do
|
ApCodec oc1 oc2 -> do
|
||||||
ss1 <- goObject oc1
|
ss1 <- goObject oc1
|
||||||
ss2 <- goObject oc2
|
ss2 <- goObject oc2
|
||||||
@ -180,8 +180,8 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
}
|
}
|
||||||
combineObjectSchemas :: [Schema] -> Schema
|
combineObjectSchemas :: [Schema] -> Schema
|
||||||
combineObjectSchemas = mconcat
|
combineObjectSchemas = mconcat
|
||||||
combineSchemaOr :: Schema -> Schema -> Schema
|
combineSchemaOr :: Union -> Schema -> Schema -> Schema
|
||||||
combineSchemaOr s1 s2 =
|
combineSchemaOr u s1 s2 =
|
||||||
let ps1 = _schemaParamSchema s1
|
let ps1 = _schemaParamSchema s1
|
||||||
ps2 = _schemaParamSchema s2
|
ps2 = _schemaParamSchema s2
|
||||||
-- Swagger 2 doesn't support sum types so we have to work around that here.
|
-- Swagger 2 doesn't support sum types so we have to work around that here.
|
||||||
@ -195,7 +195,9 @@ declareNamedSchemaVia c' Proxy = go c'
|
|||||||
-- the schema: one which lets any value through.
|
-- the schema: one which lets any value through.
|
||||||
overApproximation =
|
overApproximation =
|
||||||
mempty
|
mempty
|
||||||
{ _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True
|
{ _schemaAdditionalProperties = case u of
|
||||||
|
PossiblyJointUnion -> Just $ AdditionalPropertiesAllowed True
|
||||||
|
DisjointUnion -> Nothing
|
||||||
}
|
}
|
||||||
in case (,) <$> _paramSchemaEnum ps1 <*> _paramSchemaEnum ps2 of
|
in case (,) <$> _paramSchemaEnum ps1 <*> _paramSchemaEnum ps2 of
|
||||||
(Just (es1, es2)) ->
|
(Just (es1, es2)) ->
|
||||||
|
@ -1,5 +1,11 @@
|
|||||||
# Changelog
|
# Changelog
|
||||||
|
|
||||||
|
## [0.1.0.0] - 2021-12-23
|
||||||
|
|
||||||
|
### Changed
|
||||||
|
|
||||||
|
* Support for `autodocodec-schema >=0.1.0.0` with comments for `anyOf` and `oneOf`.
|
||||||
|
|
||||||
## [0.0.0.0] - 2021-11-19
|
## [0.0.0.0] - 2021-11-19
|
||||||
|
|
||||||
First release.
|
First release.
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
-- This file has been generated from package.yaml by hpack version 0.34.5.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: autodocodec-yaml
|
name: autodocodec-yaml
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
synopsis: Autodocodec interpreters for yaml
|
synopsis: Autodocodec interpreters for yaml
|
||||||
homepage: https://github.com/NorfairKing/autodocodec#readme
|
homepage: https://github.com/NorfairKing/autodocodec#readme
|
||||||
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
||||||
@ -35,7 +35,7 @@ library
|
|||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
autodocodec
|
autodocodec
|
||||||
, autodocodec-schema
|
, autodocodec-schema >=0.1.0.0
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
, bytestring
|
, bytestring
|
||||||
, containers
|
, containers
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
name: autodocodec-yaml
|
name: autodocodec-yaml
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
github: "NorfairKing/autodocodec"
|
github: "NorfairKing/autodocodec"
|
||||||
license: MIT
|
license: MIT
|
||||||
author: "Tom Sydney Kerckhove"
|
author: "Tom Sydney Kerckhove"
|
||||||
@ -18,7 +18,7 @@ library:
|
|||||||
source-dirs: src
|
source-dirs: src
|
||||||
dependencies:
|
dependencies:
|
||||||
- autodocodec
|
- autodocodec
|
||||||
- autodocodec-schema
|
- autodocodec-schema >=0.1.0.0
|
||||||
- bytestring
|
- bytestring
|
||||||
- containers
|
- containers
|
||||||
- path
|
- path
|
||||||
|
@ -42,7 +42,7 @@ toYamlVia = flip go
|
|||||||
ValueCodec -> yamlValue (a :: JSON.Value)
|
ValueCodec -> yamlValue (a :: JSON.Value)
|
||||||
EqCodec value c -> go value c
|
EqCodec value c -> go value c
|
||||||
BimapCodec _ g c -> go (g a) c
|
BimapCodec _ g c -> go (g a) c
|
||||||
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
|
||||||
Left a1 -> go a1 c1
|
Left a1 -> go a1 c1
|
||||||
Right a2 -> go a2 c2
|
Right a2 -> go a2 c2
|
||||||
CommentCodec _ c -> go a c
|
CommentCodec _ c -> go a c
|
||||||
@ -60,7 +60,7 @@ toYamlVia = flip go
|
|||||||
then []
|
then []
|
||||||
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
|
||||||
BimapCodec _ g c -> goObject (g a) c
|
BimapCodec _ g c -> goObject (g a) c
|
||||||
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
|
||||||
Left a1 -> goObject a1 c1
|
Left a1 -> goObject a1 c1
|
||||||
Right a2 -> goObject a2 c2
|
Right a2 -> goObject a2 c2
|
||||||
PureCodec _ -> []
|
PureCodec _ -> []
|
||||||
|
@ -63,6 +63,20 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
|
|||||||
docToLines :: Text -> [[Chunk]]
|
docToLines :: Text -> [[Chunk]]
|
||||||
docToLines doc = map (\line -> [chunk "# ", chunk line]) (T.lines doc)
|
docToLines doc = map (\line -> [chunk "# ", chunk line]) (T.lines doc)
|
||||||
|
|
||||||
|
choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
|
||||||
|
choiceChunks = \case
|
||||||
|
chunks :| [] -> addInFrontOfFirstInList ["[ "] chunks ++ [["]"]]
|
||||||
|
(chunks :| restChunks) ->
|
||||||
|
concat $
|
||||||
|
addInFrontOfFirstInList ["[ "] chunks :
|
||||||
|
map (addInFrontOfFirstInList [", "]) restChunks ++ [[["]"]]]
|
||||||
|
|
||||||
|
anyOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
|
||||||
|
anyOfChunks = (["# ", fore green "any of"] :) . choiceChunks
|
||||||
|
|
||||||
|
oneOfChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
|
||||||
|
oneOfChunks = (["# ", fore green "one of"] :) . choiceChunks
|
||||||
|
|
||||||
go :: JSONSchema -> [[Chunk]]
|
go :: JSONSchema -> [[Chunk]]
|
||||||
go = \case
|
go = \case
|
||||||
AnySchema -> [[fore yellow "<any>"]]
|
AnySchema -> [[fore yellow "<any>"]]
|
||||||
@ -90,20 +104,13 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
|
|||||||
addInFrontOfFirstInList [fore white "<key>", ": "] $ [] : go s
|
addInFrontOfFirstInList [fore white "<key>", ": "] $ [] : go s
|
||||||
ObjectSchema os -> goObject os
|
ObjectSchema os -> goObject os
|
||||||
ValueSchema v -> [[jsonValueChunk v]]
|
ValueSchema v -> [[jsonValueChunk v]]
|
||||||
ChoiceSchema ne -> choiceChunks $ NE.map go ne
|
AnyOfSchema ne -> anyOfChunks $ NE.map go ne
|
||||||
|
OneOfSchema ne -> oneOfChunks $ NE.map go ne
|
||||||
CommentSchema comment s -> docToLines comment ++ go s
|
CommentSchema comment s -> docToLines comment ++ go s
|
||||||
RefSchema name -> [[fore cyan $ chunk $ "ref: " <> name]]
|
RefSchema name -> [[fore cyan $ chunk $ "ref: " <> name]]
|
||||||
WithDefSchema defs (RefSchema _) -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs)
|
WithDefSchema defs (RefSchema _) -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs)
|
||||||
WithDefSchema defs s -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs) ++ go s
|
WithDefSchema defs s -> concatMap (\(name, s') -> [fore cyan $ chunk $ "def: " <> name] : go s') (M.toList defs) ++ go s
|
||||||
|
|
||||||
choiceChunks :: NonEmpty [[Chunk]] -> [[Chunk]]
|
|
||||||
choiceChunks = \case
|
|
||||||
chunks :| [] -> addInFrontOfFirstInList ["[ "] chunks ++ [["]"]]
|
|
||||||
(chunks :| restChunks) ->
|
|
||||||
concat $
|
|
||||||
addInFrontOfFirstInList ["[ "] chunks :
|
|
||||||
map (addInFrontOfFirstInList [", "]) restChunks ++ [[["]"]]]
|
|
||||||
|
|
||||||
goObject :: ObjectSchema -> [[Chunk]]
|
goObject :: ObjectSchema -> [[Chunk]]
|
||||||
goObject = \case
|
goObject = \case
|
||||||
ObjectAnySchema -> [["<object>"]]
|
ObjectAnySchema -> [["<object>"]]
|
||||||
@ -121,4 +128,5 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
|
|||||||
prefixLines = ["# ", requirementComment kr] : defaultValueLine ++ maybe [] docToLines mdoc
|
prefixLines = ["# ", requirementComment kr] : defaultValueLine ++ maybe [] docToLines mdoc
|
||||||
in addInFrontOfFirstInList [fore white $ chunk k, ": "] (prefixLines ++ keySchemaChunks)
|
in addInFrontOfFirstInList [fore white $ chunk k, ": "] (prefixLines ++ keySchemaChunks)
|
||||||
ObjectAllOfSchema ne -> concatMap goObject $ NE.toList ne
|
ObjectAllOfSchema ne -> concatMap goObject $ NE.toList ne
|
||||||
ObjectChoiceSchema ne -> choiceChunks $ NE.map goObject ne
|
ObjectAnyOfSchema ne -> anyOfChunks $ NE.map goObject ne
|
||||||
|
ObjectOneOfSchema ne -> oneOfChunks $ NE.map goObject ne
|
||||||
|
@ -1,5 +1,15 @@
|
|||||||
# Changelog
|
# Changelog
|
||||||
|
|
||||||
|
## [0.0.1.0] - 2021-12-23
|
||||||
|
|
||||||
|
### Changed
|
||||||
|
|
||||||
|
* `EitherCodec` now takes a `Union` to specify whether the union is disjoint or not.
|
||||||
|
|
||||||
|
### Added
|
||||||
|
|
||||||
|
* `disjointEitherCodec` and `possiblyJointEitherCodec`.
|
||||||
|
|
||||||
## [0.0.0.0] - 2021-11-19
|
## [0.0.0.0] - 2021-11-19
|
||||||
|
|
||||||
First release.
|
First release.
|
||||||
|
@ -1,11 +1,11 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
-- This file has been generated from package.yaml by hpack version 0.34.5.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: autodocodec
|
name: autodocodec
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
synopsis: Self-documenting encoder and decoder
|
synopsis: Self-documenting encoder and decoder
|
||||||
homepage: https://github.com/NorfairKing/autodocodec#readme
|
homepage: https://github.com/NorfairKing/autodocodec#readme
|
||||||
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
bug-reports: https://github.com/NorfairKing/autodocodec/issues
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
name: autodocodec
|
name: autodocodec
|
||||||
version: 0.0.0.0
|
version: 0.0.1.0
|
||||||
github: "NorfairKing/autodocodec"
|
github: "NorfairKing/autodocodec"
|
||||||
license: MIT
|
license: MIT
|
||||||
author: "Tom Sydney Kerckhove"
|
author: "Tom Sydney Kerckhove"
|
||||||
|
@ -57,25 +57,32 @@ module Autodocodec
|
|||||||
optionalFieldOrNullWithOmittedDefaultWith',
|
optionalFieldOrNullWithOmittedDefaultWith',
|
||||||
|
|
||||||
-- ** Writing your own value codecs.
|
-- ** Writing your own value codecs.
|
||||||
maybeCodec,
|
|
||||||
eitherCodec,
|
-- *** Primitive codecs
|
||||||
listCodec,
|
|
||||||
nonEmptyCodec,
|
|
||||||
singleOrListCodec,
|
|
||||||
singleOrNonEmptyCodec,
|
|
||||||
vectorCodec,
|
|
||||||
valueCodec,
|
|
||||||
nullCodec,
|
nullCodec,
|
||||||
boolCodec,
|
boolCodec,
|
||||||
textCodec,
|
textCodec,
|
||||||
stringCodec,
|
stringCodec,
|
||||||
scientificCodec,
|
scientificCodec,
|
||||||
|
valueCodec,
|
||||||
|
|
||||||
|
-- *** Integral codecs
|
||||||
boundedIntegralCodec,
|
boundedIntegralCodec,
|
||||||
boundedIntegralNumberBounds,
|
boundedIntegralNumberBounds,
|
||||||
|
|
||||||
|
-- *** Literal value codecs
|
||||||
literalTextCodec,
|
literalTextCodec,
|
||||||
literalTextValueCodec,
|
literalTextValueCodec,
|
||||||
(<?>),
|
|
||||||
(<??>),
|
-- *** Enums
|
||||||
|
shownBoundedEnumCodec,
|
||||||
|
stringConstCodec,
|
||||||
|
enumCodec,
|
||||||
|
|
||||||
|
-- *** Sum type codecs
|
||||||
|
eitherCodec,
|
||||||
|
disjointEitherCodec,
|
||||||
|
possiblyJointEitherCodec,
|
||||||
|
|
||||||
-- *** Mapping
|
-- *** Mapping
|
||||||
dimapCodec,
|
dimapCodec,
|
||||||
@ -83,10 +90,13 @@ module Autodocodec
|
|||||||
rmapCodec,
|
rmapCodec,
|
||||||
lmapCodec,
|
lmapCodec,
|
||||||
|
|
||||||
-- *** Enums
|
-- *** Composing codecs
|
||||||
shownBoundedEnumCodec,
|
maybeCodec,
|
||||||
stringConstCodec,
|
listCodec,
|
||||||
enumCodec,
|
nonEmptyCodec,
|
||||||
|
singleOrListCodec,
|
||||||
|
singleOrNonEmptyCodec,
|
||||||
|
vectorCodec,
|
||||||
|
|
||||||
-- *** Alternative parsing
|
-- *** Alternative parsing
|
||||||
parseAlternative,
|
parseAlternative,
|
||||||
@ -96,6 +106,10 @@ module Autodocodec
|
|||||||
matchChoiceCodec,
|
matchChoiceCodec,
|
||||||
matchChoicesCodec,
|
matchChoicesCodec,
|
||||||
|
|
||||||
|
-- *** Adding documentation to a codec
|
||||||
|
(<?>),
|
||||||
|
(<??>),
|
||||||
|
|
||||||
-- * Bare codec
|
-- * Bare codec
|
||||||
Codec (..),
|
Codec (..),
|
||||||
ValueCodec,
|
ValueCodec,
|
||||||
|
@ -88,12 +88,26 @@ parseJSONContextVia codec_ context_ =
|
|||||||
case f old of
|
case f old of
|
||||||
Left err -> fail err
|
Left err -> fail err
|
||||||
Right new -> pure new
|
Right new -> pure new
|
||||||
EitherCodec c1 c2 ->
|
EitherCodec u c1 c2 ->
|
||||||
let leftParser = (\v -> Left <$> go v c1)
|
let leftParser = (\v -> Left <$> go v c1)
|
||||||
rightParser = Right <$> go value c2
|
rightParser = (\v -> Right <$> go v c2)
|
||||||
in case parseEither leftParser value of
|
in case u of
|
||||||
Right l -> pure l
|
PossiblyJointUnion ->
|
||||||
Left err -> prependFailure (" Previous branch failure: " <> err <> "\n") rightParser
|
case parseEither leftParser value of
|
||||||
|
Right l -> pure l
|
||||||
|
Left err -> prependFailure (" Previous branch failure: " <> err <> "\n") (rightParser value)
|
||||||
|
DisjointUnion ->
|
||||||
|
case (parseEither leftParser value, parseEither rightParser value) of
|
||||||
|
(Left _, Right r) -> pure r
|
||||||
|
(Right l, Left _) -> pure l
|
||||||
|
(Right _, Right _) -> fail "Both branches of a disjoint union succeeded."
|
||||||
|
(Left lErr, Left rErr) ->
|
||||||
|
fail $
|
||||||
|
unlines
|
||||||
|
[ "Both branches of a disjoint union failed: ",
|
||||||
|
unwords ["Left: ", lErr],
|
||||||
|
unwords ["Right: ", rErr]
|
||||||
|
]
|
||||||
CommentCodec _ c -> go value c
|
CommentCodec _ c -> go value c
|
||||||
ReferenceCodec _ c -> go value c
|
ReferenceCodec _ c -> go value c
|
||||||
RequiredKeyCodec k c _ -> do
|
RequiredKeyCodec k c _ -> do
|
||||||
|
@ -41,7 +41,7 @@ toJSONVia = flip go
|
|||||||
ValueCodec -> (a :: JSON.Value)
|
ValueCodec -> (a :: JSON.Value)
|
||||||
EqCodec value c -> go value c
|
EqCodec value c -> go value c
|
||||||
BimapCodec _ g c -> go (g a) c
|
BimapCodec _ g c -> go (g a) c
|
||||||
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
|
||||||
Left a1 -> go a1 c1
|
Left a1 -> go a1 c1
|
||||||
Right a2 -> go a2 c2
|
Right a2 -> go a2 c2
|
||||||
CommentCodec _ c -> go a c
|
CommentCodec _ c -> go a c
|
||||||
@ -60,7 +60,7 @@ toJSONVia = flip go
|
|||||||
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
||||||
BimapCodec _ g c -> goObject (g a) c
|
BimapCodec _ g c -> goObject (g a) c
|
||||||
PureCodec _ -> mempty
|
PureCodec _ -> mempty
|
||||||
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
|
||||||
Left a1 -> goObject a1 c1
|
Left a1 -> goObject a1 c1
|
||||||
Right a2 -> goObject a2 c2
|
Right a2 -> goObject a2 c2
|
||||||
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
||||||
@ -86,7 +86,7 @@ toEncodingVia = flip go
|
|||||||
ValueCodec -> JSON.value (a :: JSON.Value)
|
ValueCodec -> JSON.value (a :: JSON.Value)
|
||||||
EqCodec value c -> go value c
|
EqCodec value c -> go value c
|
||||||
BimapCodec _ g c -> go (g a) c
|
BimapCodec _ g c -> go (g a) c
|
||||||
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
|
||||||
Left a1 -> go a1 c1
|
Left a1 -> go a1 c1
|
||||||
Right a2 -> go a2 c2
|
Right a2 -> go a2 c2
|
||||||
CommentCodec _ c -> go a c
|
CommentCodec _ c -> go a c
|
||||||
@ -104,7 +104,7 @@ toEncodingVia = flip go
|
|||||||
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
|
||||||
PureCodec _ -> mempty :: JSON.Series
|
PureCodec _ -> mempty :: JSON.Series
|
||||||
BimapCodec _ g c -> goObject (g a) c
|
BimapCodec _ g c -> goObject (g a) c
|
||||||
EitherCodec c1 c2 -> case (a :: Either _ _) of
|
EitherCodec _ c1 c2 -> case (a :: Either _ _) of
|
||||||
Left a1 -> goObject a1 c1
|
Left a1 -> goObject a1 c1
|
||||||
Right a2 -> goObject a2 c2
|
Right a2 -> goObject a2 c2
|
||||||
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
|
||||||
|
@ -103,7 +103,7 @@ instance HasCodec a => HasCodec (Maybe a) where
|
|||||||
|
|
||||||
instance (HasCodec l, HasCodec r) => HasCodec (Either l r) where
|
instance (HasCodec l, HasCodec r) => HasCodec (Either l r) where
|
||||||
codec =
|
codec =
|
||||||
eitherCodec
|
disjointEitherCodec
|
||||||
(ObjectOfCodec Nothing (requiredField' "Left"))
|
(ObjectOfCodec Nothing (requiredField' "Left"))
|
||||||
(ObjectOfCodec Nothing (requiredField' "Right"))
|
(ObjectOfCodec Nothing (requiredField' "Right"))
|
||||||
|
|
||||||
|
@ -33,9 +33,10 @@ import qualified Data.Vector as V
|
|||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
-- >>> import Autodocodec.Aeson (toJSONVia, toJSONViaCodec, parseJSONVia)
|
-- >>> import Autodocodec.Aeson (toJSONVia, toJSONViaCodec, parseJSONVia, parseJSONViaCodec)
|
||||||
-- >>> import Autodocodec.Class (HasCodec(codec))
|
-- >>> import Autodocodec.Class (HasCodec(codec), requiredField)
|
||||||
-- >>> import qualified Data.Aeson as JSON
|
-- >>> import qualified Data.Aeson as JSON
|
||||||
|
-- >>> import qualified Data.HashMap.Strict as HM
|
||||||
-- >>> import Data.Aeson (Value(..))
|
-- >>> import Data.Aeson (Value(..))
|
||||||
-- >>> import qualified Data.Vector as Vector
|
-- >>> import qualified Data.Vector as Vector
|
||||||
-- >>> import Data.Int
|
-- >>> import Data.Int
|
||||||
@ -159,6 +160,8 @@ data Codec context input output where
|
|||||||
-- In particular, you should prefer using it for values rather than objects,
|
-- In particular, you should prefer using it for values rather than objects,
|
||||||
-- because those docs are easier to generate.
|
-- because those docs are easier to generate.
|
||||||
EitherCodec ::
|
EitherCodec ::
|
||||||
|
-- | What type of union we encode and decode
|
||||||
|
!Union ->
|
||||||
-- | Codec for the 'Left' side
|
-- | Codec for the 'Left' side
|
||||||
(Codec context input1 output1) ->
|
(Codec context input1 output1) ->
|
||||||
-- | Codec for the 'Right' side
|
-- | Codec for the 'Right' side
|
||||||
@ -257,6 +260,7 @@ data NumberBounds = NumberBounds
|
|||||||
|
|
||||||
instance Validity NumberBounds
|
instance Validity NumberBounds
|
||||||
|
|
||||||
|
-- | Check if a number falls within given 'NumberBounds'.
|
||||||
checkNumberBounds :: NumberBounds -> Scientific -> Either String Scientific
|
checkNumberBounds :: NumberBounds -> Scientific -> Either String Scientific
|
||||||
checkNumberBounds NumberBounds {..} s =
|
checkNumberBounds NumberBounds {..} s =
|
||||||
if numberBoundsLower <= s
|
if numberBoundsLower <= s
|
||||||
@ -266,6 +270,16 @@ checkNumberBounds NumberBounds {..} s =
|
|||||||
else Left $ unwords ["Number", show s, "is bigger than the upper bound", show numberBoundsUpper]
|
else Left $ unwords ["Number", show s, "is bigger than the upper bound", show numberBoundsUpper]
|
||||||
else Left $ unwords ["Number", show s, "is smaller than the lower bound", show numberBoundsUpper]
|
else Left $ unwords ["Number", show s, "is smaller than the lower bound", show numberBoundsUpper]
|
||||||
|
|
||||||
|
-- | What type of union the encoding uses
|
||||||
|
data Union
|
||||||
|
= -- | Not disjoint, see 'possiblyJointEitherCodec'.
|
||||||
|
PossiblyJointUnion
|
||||||
|
| -- | Disjoint, see 'disjointEitherCodec'.
|
||||||
|
DisjointUnion
|
||||||
|
deriving (Show, Eq, Generic)
|
||||||
|
|
||||||
|
instance Validity Union
|
||||||
|
|
||||||
-- | A codec within the 'JSON.Value' context.
|
-- | A codec within the 'JSON.Value' context.
|
||||||
--
|
--
|
||||||
-- An 'ValueCodec' can be used to turn a Haskell value into a 'JSON.Value' or to parse a 'JSON.Value' into a haskell value.
|
-- An 'ValueCodec' can be used to turn a Haskell value into a 'JSON.Value' or to parse a 'JSON.Value' into a haskell value.
|
||||||
@ -316,7 +330,7 @@ showCodecABit = ($ "") . (`evalState` S.empty) . go 0
|
|||||||
HashMapCodec c -> (\s -> showParen (d > 10) $ showString "HashMapCodec" . s) <$> go 11 c
|
HashMapCodec c -> (\s -> showParen (d > 10) $ showString "HashMapCodec" . s) <$> go 11 c
|
||||||
EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec 11 value . showString " " . s) <$> go 11 c
|
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
|
BimapCodec _ _ c -> (\s -> showParen (d > 10) $ showString "BimapCodec _ _ " . s) <$> go 11 c
|
||||||
EitherCodec c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2
|
EitherCodec u c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . showsPrec 11 u . showString " " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2
|
||||||
CommentCodec comment c -> (\s -> showParen (d > 10) $ showString "CommentCodec " . showsPrec 11 comment . showString " " . s) <$> go 11 c
|
CommentCodec comment c -> (\s -> showParen (d > 10) $ showString "CommentCodec " . showsPrec 11 comment . showString " " . s) <$> go 11 c
|
||||||
ReferenceCodec name c -> do
|
ReferenceCodec name c -> do
|
||||||
alreadySeen <- gets (S.member name)
|
alreadySeen <- gets (S.member name)
|
||||||
@ -438,7 +452,11 @@ instance Applicative (ObjectCodec input) where
|
|||||||
-- >>> toJSONVia (maybeCodec codec) (Nothing :: Maybe Char)
|
-- >>> toJSONVia (maybeCodec codec) (Nothing :: Maybe Char)
|
||||||
-- Null
|
-- Null
|
||||||
maybeCodec :: ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)
|
maybeCodec :: ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)
|
||||||
maybeCodec = dimapCodec f g . EitherCodec nullCodec
|
maybeCodec =
|
||||||
|
-- We must use 'possiblyJointEitherCodec' here, otherwise a codec for (Maybe
|
||||||
|
-- (Maybe Text)) will fail to parse.
|
||||||
|
dimapCodec f g
|
||||||
|
. possiblyJointEitherCodec nullCodec
|
||||||
where
|
where
|
||||||
f = \case
|
f = \case
|
||||||
Left () -> Nothing
|
Left () -> Nothing
|
||||||
@ -449,19 +467,113 @@ maybeCodec = dimapCodec f g . EitherCodec nullCodec
|
|||||||
|
|
||||||
-- | Forward-compatible version of 'EitherCodec'
|
-- | Forward-compatible version of 'EitherCodec'
|
||||||
--
|
--
|
||||||
-- > eitherCodec = EitherCodec
|
-- > eitherCodec = EitherCodec PossiblyJointUnion
|
||||||
--
|
--
|
||||||
-- === 'HasCodec' instance for sum types
|
-- === 'HasCodec' instance for sum types
|
||||||
--
|
--
|
||||||
-- The 'eitherCodec' can be used to implement 'HasCodec' instances for newtypes.
|
-- To write a 'HasCodec' instance for sum types, you will need to decide whether encoding is disjoint or not.
|
||||||
|
-- The default, so also the implementation of this function, is 'possiblyJointEitherCodec', but you may want to use 'disjointEitherCodec' instead.
|
||||||
|
--
|
||||||
|
-- Ask yourself: Can the encoding of a 'Left' value be decoded as 'Right' value (or vice versa)?
|
||||||
|
--
|
||||||
|
-- @Yes ->@ use 'possiblyJointEitherCodec'.
|
||||||
|
--
|
||||||
|
-- @No ->@ use 'disjointEitherCodec'.
|
||||||
|
--
|
||||||
|
-- === Example usage
|
||||||
|
--
|
||||||
|
-- >>> let c = eitherCodec codec codec :: JSONCodec (Either Int String)
|
||||||
|
-- >>> toJSONVia c (Left 5)
|
||||||
|
-- Number 5.0
|
||||||
|
-- >>> toJSONVia c (Right "hello")
|
||||||
|
-- String "hello"
|
||||||
|
-- >>> JSON.parseMaybe (parseJSONVia c) (String "world") :: Maybe (Either Int String)
|
||||||
|
-- Just (Right "world")
|
||||||
|
eitherCodec ::
|
||||||
|
-- |
|
||||||
|
Codec context input1 output1 ->
|
||||||
|
-- |
|
||||||
|
Codec context input2 output2 ->
|
||||||
|
-- |
|
||||||
|
Codec context (Either input1 input2) (Either output1 output2)
|
||||||
|
eitherCodec = possiblyJointEitherCodec
|
||||||
|
|
||||||
|
-- | Forward-compatible version of 'EitherCodec PossiblyJointUnion'
|
||||||
|
--
|
||||||
|
-- > possiblyJointEitherCodec = EitherCodec PossiblyJointUnion
|
||||||
|
--
|
||||||
|
-- === 'HasCodec' instance for sum types with an encoding that is not disjoint.
|
||||||
|
--
|
||||||
|
-- The 'eitherCodec' can be used to implement 'HasCodec' instances for sum types.
|
||||||
-- If you just have two codecs that you want to try in order, while parsing, you can do this:
|
-- If you just have two codecs that you want to try in order, while parsing, you can do this:
|
||||||
--
|
--
|
||||||
-- >>> data War = WorldWar Word8 | OtherWar Text
|
-- >>> :{
|
||||||
|
-- data Ainur
|
||||||
|
-- = Valar Text Text
|
||||||
|
-- | Maiar Text
|
||||||
|
-- deriving (Show, Eq)
|
||||||
|
-- :}
|
||||||
|
--
|
||||||
|
-- >>> :{
|
||||||
|
-- instance HasCodec Ainur where
|
||||||
|
-- codec =
|
||||||
|
-- dimapCodec f g $
|
||||||
|
-- possiblyJointEitherCodec
|
||||||
|
-- (object "Valar" $
|
||||||
|
-- (,)
|
||||||
|
-- <$> requiredField "domain" "Domain which the Valar rules over" .= fst
|
||||||
|
-- <*> requiredField "name" "Name of the Valar" .= snd)
|
||||||
|
-- (object "Maiar" $ requiredField "name" "Name of the Maiar")
|
||||||
|
-- where
|
||||||
|
-- f = \case
|
||||||
|
-- Left (domain, name) -> Valar domain name
|
||||||
|
-- Right name -> Maiar name
|
||||||
|
-- g = \case
|
||||||
|
-- Valar domain name -> Left (domain, name)
|
||||||
|
-- Maiar name -> Right name
|
||||||
|
-- :}
|
||||||
|
--
|
||||||
|
-- Note that this encoding is indeed not disjoint, because a @Valar@ object can
|
||||||
|
-- parse as a @Maiar@ value.
|
||||||
|
--
|
||||||
|
-- >>> toJSONViaCodec (Valar "Stars" "Varda")
|
||||||
|
-- Object (fromList [("domain",String "Stars"),("name",String "Varda")])
|
||||||
|
-- >>> toJSONViaCodec (Maiar "Sauron")
|
||||||
|
-- Object (fromList [("name",String "Sauron")])
|
||||||
|
-- >>> JSON.parseMaybe parseJSONViaCodec (Object (HM.fromList [("name",String "Olorin")])) :: Maybe Ainur
|
||||||
|
-- Just (Maiar "Olorin")
|
||||||
|
--
|
||||||
|
-- === WARNING
|
||||||
|
--
|
||||||
|
-- The order of the codecs in a 'possiblyJointEitherCodec' matters.
|
||||||
|
--
|
||||||
|
-- In the above example, decoding works as expected because the @Valar@ case is parsed first.
|
||||||
|
-- If the @Maiar@ case were first in the 'possiblyJointEitherCodec', then
|
||||||
|
-- @Valar@ could never be parsed.
|
||||||
|
possiblyJointEitherCodec ::
|
||||||
|
-- |
|
||||||
|
Codec context input1 output1 ->
|
||||||
|
-- |
|
||||||
|
Codec context input2 output2 ->
|
||||||
|
-- |
|
||||||
|
Codec context (Either input1 input2) (Either output1 output2)
|
||||||
|
possiblyJointEitherCodec = EitherCodec PossiblyJointUnion
|
||||||
|
|
||||||
|
-- | Forward-compatible version of 'EitherCodec DisjointUnion'
|
||||||
|
--
|
||||||
|
-- > disjointEitherCodec = EitherCodec DisjointUnion
|
||||||
|
--
|
||||||
|
-- === 'HasCodec' instance for sum types with an encoding that is definitely disjoint.
|
||||||
|
--
|
||||||
|
-- The 'eitherCodec' can be used to implement 'HasCodec' instances sum types
|
||||||
|
-- for which the encoding is definitely disjoint.
|
||||||
|
--
|
||||||
|
-- >>> data War = WorldWar Word8 | OtherWar Text deriving (Show, Eq)
|
||||||
-- >>> :{
|
-- >>> :{
|
||||||
-- instance HasCodec War where
|
-- instance HasCodec War where
|
||||||
-- codec =
|
-- codec =
|
||||||
-- dimapCodec f g $
|
-- dimapCodec f g $
|
||||||
-- eitherCodec
|
-- disjointEitherCodec
|
||||||
-- (codec :: JSONCodec Word8)
|
-- (codec :: JSONCodec Word8)
|
||||||
-- (codec :: JSONCodec Text)
|
-- (codec :: JSONCodec Text)
|
||||||
-- where
|
-- where
|
||||||
@ -473,22 +585,46 @@ maybeCodec = dimapCodec f g . EitherCodec nullCodec
|
|||||||
-- OtherWar t -> Right t
|
-- OtherWar t -> Right t
|
||||||
-- :}
|
-- :}
|
||||||
--
|
--
|
||||||
|
-- Note that this incoding is indeed disjoint because an encoded 'String' can
|
||||||
|
-- never be parsed as an 'Word8' and vice versa.
|
||||||
|
--
|
||||||
-- >>> toJSONViaCodec (WorldWar 2)
|
-- >>> toJSONViaCodec (WorldWar 2)
|
||||||
-- Number 2.0
|
-- Number 2.0
|
||||||
-- >>> toJSONViaCodec (OtherWar "OnDrugs")
|
-- >>> toJSONViaCodec (OtherWar "OnDrugs")
|
||||||
-- String "OnDrugs"
|
-- String "OnDrugs"
|
||||||
|
-- >>> JSON.parseMaybe parseJSONViaCodec (String "of the roses") :: Maybe War
|
||||||
|
-- Just (OtherWar "of the roses")
|
||||||
|
--
|
||||||
|
-- === WARNING
|
||||||
|
--
|
||||||
|
-- If it turns out that the encoding of a value is not disjoint, decoding may
|
||||||
|
-- fail and documentation may be wrong.
|
||||||
|
--
|
||||||
|
-- >>> let c = disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec Int)
|
||||||
|
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5) :: Maybe (Either Int Int)
|
||||||
|
-- Nothing
|
||||||
|
--
|
||||||
|
-- Encoding still works as expected, however:
|
||||||
|
--
|
||||||
|
-- >>> toJSONVia c (Left 5)
|
||||||
|
-- Number 5.0
|
||||||
|
-- >>> toJSONVia c (Right 6)
|
||||||
|
-- Number 6.0
|
||||||
--
|
--
|
||||||
-- === Example usage
|
-- === Example usage
|
||||||
--
|
--
|
||||||
-- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)
|
-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)
|
||||||
-- Number 5.0
|
-- Number 5.0
|
||||||
-- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")
|
-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")
|
||||||
-- String "hello"
|
-- String "hello"
|
||||||
eitherCodec ::
|
disjointEitherCodec ::
|
||||||
|
-- |
|
||||||
Codec context input1 output1 ->
|
Codec context input1 output1 ->
|
||||||
|
-- |
|
||||||
Codec context input2 output2 ->
|
Codec context input2 output2 ->
|
||||||
|
-- |
|
||||||
Codec context (Either input1 input2) (Either output1 output2)
|
Codec context (Either input1 input2) (Either output1 output2)
|
||||||
eitherCodec = EitherCodec
|
disjointEitherCodec = EitherCodec DisjointUnion
|
||||||
|
|
||||||
-- | Map a codec's input and output types.
|
-- | Map a codec's input and output types.
|
||||||
--
|
--
|
||||||
|
Loading…
Reference in New Issue
Block a user