Support disjoint unions

autodocodec-api-usage/src/Autodocodec/Usage.hs

@@ -28,6 +28,7 @@ import Data.Maybe
 import qualified Data.OpenApi as OpenAPI
 import qualified Data.Swagger as Swagger
 import Data.Text (Text)
+import Data.Word
 import GHC.Generics (Generic)
 import Test.QuickCheck
 
@@ -341,3 +342,75 @@ instance HasCodec LegacyObject where
             requiredField "oldest" "oldest key"
           ]
           .= 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

autodocodec-api-usage/test/Autodocodec/Aeson/SchemaSpec.hs

@@ -75,20 +75,23 @@ spec = do
   jsonSchemaSpec @VeryComment "very-comment"
   jsonSchemaSpec @LegacyValue "legacy-value"
   jsonSchemaSpec @LegacyObject "legacy-object"
+  jsonSchemaSpec @Ainur "ainur"
+  jsonSchemaSpec @War "war"
   describe "JSONSchema" $ do
     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
     genValidSpec @ObjectSchema
     it "roundtrips through object and back" $
@@ -115,9 +118,10 @@ instance GenValid JSONSchema where
     ArraySchema s -> AnySchema : s : (ArraySchema <$> shrinkValid s)
     ObjectSchema os -> AnySchema : (ObjectSchema <$> shrinkValid os)
     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
       (k', s') <- shrinkValid (k, s)
       pure $ CommentSchema k' s'
@@ -141,7 +145,15 @@ instance GenValid JSONSchema where
               choice2 <- resize b genValid
               rest <- resize c genValid
               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),
             do
               (a, b) <- genSplit (n -1)
@@ -155,7 +167,8 @@ instance GenValid JSONSchema where
 instance GenValid ObjectSchema where
   shrinkValid os = case os of
     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)
     _ -> shrinkValidStructurallyWithoutExtraFiltering os
   genValid = oneof [pure ObjectAnySchema, go]
@@ -163,7 +176,8 @@ instance GenValid ObjectSchema where
       go =
         oneof
           [ ObjectKeySchema <$> genValid <*> genValid <*> genValid <*> genValid,
-            ObjectChoiceSchema <$> genValid,
+            ObjectAnyOfSchema <$> genValid,
+            ObjectOneOfSchema <$> genValid,
             ObjectAllOfSchema <$> genValid
           ]
 

autodocodec-api-usage/test/Autodocodec/AesonSpec.hs

@@ -92,6 +92,8 @@ spec = do
   aesonCodecSpec @VeryComment
   aesonCodecSpec @LegacyValue
   aesonCodecSpec @LegacyObject
+  aesonCodecSpec @Ainur
+  aesonCodecSpec @War
 
 aesonCodecErrorSpec :: forall a. (Show a, Eq a, Typeable a, GenValid a, HasCodec a) => FilePath -> LB.ByteString -> Spec
 aesonCodecErrorSpec filePath encoded =

autodocodec-api-usage/test/Autodocodec/OpenAPISpec.hs

@@ -80,6 +80,8 @@ spec = do
   openAPISchemaSpec @VeryComment "very-comment"
   openAPISchemaSpec @LegacyValue "legacy-value"
   openAPISchemaSpec @LegacyObject "legacy-object"
+  openAPISchemaSpec @Ainur "ainur"
+  openAPISchemaSpec @War "war"
 
 openAPISchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
 openAPISchemaSpec filePath =

autodocodec-api-usage/test/Autodocodec/ShowSpec.hs

@@ -68,6 +68,8 @@ spec = do
   showCodecSpec @VeryComment "very-comment"
   showCodecSpec @LegacyValue "legacy-value"
   showCodecSpec @LegacyObject "legacy-object"
+  showCodecSpec @Ainur "ainur"
+  showCodecSpec @War "war"
 
 showCodecSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
 showCodecSpec filePath =

autodocodec-api-usage/test/Autodocodec/SwaggerSpec.hs

@@ -80,6 +80,8 @@ spec = do
   swaggerSchemaSpec @VeryComment "very-comment"
   swaggerSchemaSpec @LegacyValue "legacy-value"
   swaggerSchemaSpec @LegacyObject "legacy-object"
+  swaggerSchemaSpec @Ainur "ainur"
+  swaggerSchemaSpec @War "war"
 
 swaggerSchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
 swaggerSchemaSpec filePath =

autodocodec-api-usage/test/Autodocodec/Yaml/SchemaSpec.hs

@@ -72,6 +72,8 @@ spec = do
   yamlSchemaSpec @VeryComment "very-comment"
   yamlSchemaSpec @LegacyValue "legacy-value"
   yamlSchemaSpec @LegacyObject "legacy-object"
+  yamlSchemaSpec @Ainur "ainur"
+  yamlSchemaSpec @War "war"
 
 yamlSchemaSpec :: forall a. (Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
 yamlSchemaSpec filePath = do

autodocodec-api-usage/test/Autodocodec/YamlSpec.hs

@@ -73,6 +73,8 @@ spec = do
   yamlCodecSpec @VeryComment
   yamlCodecSpec @LegacyValue
   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 = describe (nameOf @a) $ do

autodocodec-api-usage/test_resources/error/either-bool-text-error-array.txt

@@ -1,3 +1,4 @@
 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

autodocodec-api-usage/test_resources/json-schema/ainur.json

@@ -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"
+                }
+            }
+        }
+    ]
+}

autodocodec-api-usage/test_resources/json-schema/either-bool-text.json

@@ -1,5 +1,5 @@
 {
-    "anyOf": [
+    "oneOf": [
         {
             "required": [
                 "Left"

autodocodec-api-usage/test_resources/json-schema/either-either-bool-scientific-text.json

@@ -1,5 +1,5 @@
 {
-    "anyOf": [
+    "oneOf": [
         {
             "required": [
                 "Left"
@@ -7,7 +7,7 @@
             "type": "object",
             "properties": {
                 "Left": {
-                    "anyOf": [
+                    "oneOf": [
                         {
                             "required": [
                                 "Left"

autodocodec-api-usage/test_resources/json-schema/war.json

@@ -0,0 +1,12 @@
+{
+    "oneOf": [
+        {
+            "maximum": 255,
+            "minimum": 0,
+            "type": "number"
+        },
+        {
+            "type": "string"
+        }
+    ]
+}

autodocodec-api-usage/test_resources/openapi-schema/ainur.json

@@ -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": {}
+}

autodocodec-api-usage/test_resources/openapi-schema/either-bool-text.json

@@ -2,7 +2,7 @@
     "components": {
         "schemas": {
             "(Either Bool Text)": {
-                "anyOf": [
+                "oneOf": [
                     {
                         "required": [
                             "Left"
@@ -25,8 +25,7 @@
                             }
                         }
                     }
-                ],
+                ]
-                "additionalProperties": true
             }
         }
     },

autodocodec-api-usage/test_resources/openapi-schema/either-either-bool-scientific-text.json

@@ -2,7 +2,7 @@
     "components": {
         "schemas": {
             "(Either (Either Bool Scientific) Text)": {
-                "anyOf": [
+                "oneOf": [
                     {
                         "required": [
                             "Left"
@@ -10,7 +10,7 @@
                         "type": "object",
                         "properties": {
                             "Left": {
-                                "anyOf": [
+                                "oneOf": [
                                     {
                                         "required": [
                                             "Left"
@@ -33,8 +33,7 @@
                                             }
                                         }
                                     }
-                                ],
+                                ]
-                                "additionalProperties": true
                             }
                         }
                     },
@@ -49,8 +48,7 @@
                             }
                         }
                     }
-                ],
+                ]
-                "additionalProperties": true
             }
         }
     },

autodocodec-api-usage/test_resources/openapi-schema/war.json

@@ -0,0 +1,24 @@
+{
+    "components": {
+        "schemas": {
+            "War": {
+                "oneOf": [
+                    {
+                        "maximum": 255,
+                        "minimum": 0,
+                        "type": "number"
+                    },
+                    {
+                        "type": "string"
+                    }
+                ]
+            }
+        }
+    },
+    "openapi": "3.0.0",
+    "info": {
+        "version": "",
+        "title": ""
+    },
+    "paths": {}
+}

autodocodec-api-usage/test_resources/show-codec/ainur.txt

@@ -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))))

autodocodec-api-usage/test_resources/show-codec/either-bool-text.txt

@@ -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)))

autodocodec-api-usage/test_resources/show-codec/either-either-bool-scientific-text.txt

@@ -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)))

autodocodec-api-usage/test_resources/show-codec/example.txt

@@ -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))))))))))))

autodocodec-api-usage/test_resources/show-codec/fruit.txt

@@ -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))))))))

autodocodec-api-usage/test_resources/show-codec/legacy-object.txt

@@ -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)))))))))))))

autodocodec-api-usage/test_resources/show-codec/legacy-value.txt

@@ -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))))))

autodocodec-api-usage/test_resources/show-codec/maybe-text.txt

@@ -1 +1 @@
-BimapCodec _ _ (EitherCodec NullCodec (StringCodec Nothing))
+BimapCodec _ _ (EitherCodec PossiblyJointUnion NullCodec (StringCodec Nothing))

autodocodec-api-usage/test_resources/show-codec/ordering.txt

@@ -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))))))

autodocodec-api-usage/test_resources/show-codec/recursive.txt

@@ -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")))))

autodocodec-api-usage/test_resources/show-codec/war.txt

@@ -0,0 +1 @@
+BimapCodec _ _ (EitherCodec DisjointUnion (BimapCodec _ _ (NumberCodec Nothing (Just (NumberBounds {numberBoundsLower = 0.0, numberBoundsUpper = 255.0})))) (StringCodec Nothing))

autodocodec-api-usage/test_resources/swagger-schema/ainur.json

@@ -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"
+                }
+            }
+        }
+    }
+}

autodocodec-api-usage/test_resources/swagger-schema/war.json

@@ -0,0 +1,10 @@
+{
+    "swagger": "2.0",
+    "info": {
+        "version": "",
+        "title": ""
+    },
+    "definitions": {
+        "War": {}
+    }
+}

autodocodec-api-usage/test_resources/yaml-schema/ainur.txt

@@ -0,0 +1,13 @@
+# any of
+[ # Valar
+  domain: # required
+    # Domain which the Valar rules over
+    <string>
+  name: # required
+    # Name of the Valar
+    <string>
+, # Maiar
+  name: # required
+    # Name of the Maiar
+    <string>
+]

autodocodec-api-usage/test_resources/yaml-schema/either-bool-text.txt

@@ -1,3 +1,4 @@
+# one of
 [ Left: # required
     <boolean>
 , Right: # required

autodocodec-api-usage/test_resources/yaml-schema/either-either-bool-scientific-text.txt

@@ -1,4 +1,6 @@
+# one of
 [ Left: # required
+    # one of
     [ Left: # required
         <boolean>
     , Right: # required

autodocodec-api-usage/test_resources/yaml-schema/example.txt

@@ -7,6 +7,7 @@
   <boolean>
 maybe: # required
   # a maybe text
+  # any of
   [ null
   , <string>
   ]
@@ -15,6 +16,7 @@
   <string>
 optional-or-null: # optional
   # an optional-or-null text
+  # any of
   [ null
   , <string>
   ]
@@ -29,11 +31,13 @@
 single-or-list: # optional
   # default: []
   # an optional list that can also be specified as a single element
+  # any of
   [ <string>
   , - <string>
   ]
 fruit: # required
   # fruit!!
+  # any of
   [ Apple
   , Orange
   , Banana

autodocodec-api-usage/test_resources/yaml-schema/fruit.txt

@@ -1,3 +1,4 @@
+# any of
 [ Apple
 , Orange
 , Banana

autodocodec-api-usage/test_resources/yaml-schema/legacy-object.txt

@@ -1,4 +1,5 @@
 # LegacyObject
+# any of
 [ 1: # required
     # text 1
     <string>
@@ -6,6 +7,7 @@
     # text 1
     <string>
 ]
+# any of
 [ 2: # required
     # text 2
     <string>
@@ -13,6 +15,7 @@
     # text 2
     <string>
 ]
+# any of
 [ 3: # required
     # text 3
     <string>
@@ -20,6 +23,7 @@
     # text 3
     <string>
 ]
+# any of
 [ newest: # required
     # newest key
     <string>

autodocodec-api-usage/test_resources/yaml-schema/legacy-value.txt

@@ -1,3 +1,4 @@
+# any of
 [ # LegacyValue
   1: # required
     # text 1

autodocodec-api-usage/test_resources/yaml-schema/maybe-text.txt

@@ -1,3 +1,4 @@
+# any of
 [ null
 , <string>
 ]

autodocodec-api-usage/test_resources/yaml-schema/ordering.txt

@@ -1,3 +1,4 @@
+# any of
 [ LT
 , EQ
 , GT

autodocodec-api-usage/test_resources/yaml-schema/recursive.txt

@@ -1,4 +1,5 @@
 def: recursive
+# any of
 [ # base case
   <number> # between -9223372036854775808 and 9223372036854775807
 , # Recurse

autodocodec-api-usage/test_resources/yaml-schema/war.txt

@@ -0,0 +1,4 @@
+# one of
+[ <number> # between 0 and 255
+, <string>
+]

autodocodec-openapi3/CHANGELOG.md

@@ -1,5 +1,11 @@
 # 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
 
 First release.

autodocodec-openapi3/autodocodec-openapi3.cabal

@@ -1,11 +1,11 @@
 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
 
 name:           autodocodec-openapi3
-version:        0.0.0.0
+version:        0.0.1.0
 synopsis:       Autodocodec interpreters for openapi3
 homepage:       https://github.com/NorfairKing/autodocodec#readme
 bug-reports:    https://github.com/NorfairKing/autodocodec/issues
@@ -37,6 +37,7 @@ library
     , autodocodec
     , base >=4.7 && <5
     , insert-ordered-containers
+    , lens
     , openapi3
     , scientific
     , text

autodocodec-openapi3/package.yaml

@@ -1,5 +1,5 @@
 name: autodocodec-openapi3
-version: 0.0.0.0
+version: 0.0.1.0
 github: "NorfairKing/autodocodec"
 license: MIT
 author: "Tom Sydney Kerckhove"
@@ -20,6 +20,7 @@ library:
   - aeson
   - autodocodec
   - insert-ordered-containers
-  - scientific
+  - lens
   - openapi3
+  - scientific
   - text

autodocodec-openapi3/src/Autodocodec/OpenAPI/Schema.hs

@@ -10,6 +10,7 @@
 module Autodocodec.OpenAPI.Schema where
 
 import Autodocodec
+import Control.Lens (Lens', (&), (?~), (^.))
 import Control.Monad
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.OpenApi as OpenAPI
@@ -86,10 +87,10 @@ declareNamedSchemaVia c' Proxy = go c'
       ObjectOfCodec mname oc -> do
         ss <- goObject oc
         pure $ NamedSchema mname $ combineObjectSchemas ss
-      EitherCodec c1 c2 -> do
+      EitherCodec u c1 c2 -> do
         ns1 <- go c1
         ns2 <- go c2
-        combineSchemasOr ns1 ns2
+        combineSchemasOr u ns1 ns2
       CommentCodec t c -> do
         NamedSchema mName s <- go c
         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)
       PureCodec _ -> pure []
-      EitherCodec oc1 oc2 -> do
+      EitherCodec u oc1 oc2 -> do
         s1s <- goObject oc1
         s2s <- goObject oc2
         (: []) . _namedSchemaSchema
           <$> combineSchemasOr
+            u
             (NamedSchema Nothing (combineObjectSchemas s1s))
             (NamedSchema Nothing (combineObjectSchemas s2s))
       ApCodec oc1 oc2 -> do
@@ -160,19 +162,28 @@ declareNamedSchemaVia c' Proxy = go c'
         }
     combineObjectSchemas :: [Schema] -> Schema
     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 s2 = _namedSchemaSchema ns2
       s1Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns1
       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 $
-        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 namedSchema =

autodocodec-schema/CHANGELOG.md

@@ -1,5 +1,15 @@
 # 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
 
 First release.

autodocodec-schema/autodocodec-schema.cabal

@@ -1,11 +1,11 @@
 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
 
 name:           autodocodec-schema
-version:        0.0.0.0
+version:        0.1.0.0
 synopsis:       Autodocodec interpreters for JSON Schema
 homepage:       https://github.com/NorfairKing/autodocodec#readme
 bug-reports:    https://github.com/NorfairKing/autodocodec/issues
@@ -32,7 +32,7 @@ library
       src
   build-depends:
       aeson
-    , autodocodec
+    , autodocodec >=0.0.1.0
     , base >=4.7 && <5
     , containers
     , mtl

autodocodec-schema/package.yaml

@@ -1,5 +1,5 @@
 name: autodocodec-schema
-version: 0.0.0.0
+version: 0.1.0.0
 github: "NorfairKing/autodocodec"
 license: MIT
 author: "Tom Sydney Kerckhove"
@@ -18,7 +18,7 @@ library:
   source-dirs: src
   dependencies:
   - aeson
-  - autodocodec
+  - autodocodec >=0.0.1.0
   - containers
   - mtl
   - text

autodocodec-schema/src/Autodocodec/Schema.hs

@@ -48,7 +48,8 @@ data JSONSchema
   | -- | This needs to be a list because keys should stay in their original ordering.
     ObjectSchema ObjectSchema
   | ValueSchema !JSON.Value
-  | ChoiceSchema !(NonEmpty JSONSchema)
+  | AnyOfSchema !(NonEmpty JSONSchema)
+  | OneOfSchema !(NonEmpty JSONSchema)
   | CommentSchema !Text !JSONSchema
   | RefSchema !Text
   | WithDefSchema !(Map Text JSONSchema) !JSONSchema
@@ -62,7 +63,8 @@ instance Validity JSONSchema where
           CommentSchema _ (CommentSchema _ _) -> False
           _ -> True,
         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
       ]
 
@@ -90,12 +92,18 @@ instance ToJSON JSONSchema where
           case toJSON os of
             JSON.Object o -> HM.toList o
             _ -> [] -- Should not happen.
-        ChoiceSchema jcs ->
+        AnyOfSchema 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 [("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)) ->
           go (CommentSchema (outerComment <> "\n" <> innerComment) s)
         CommentSchema comment s -> ("$comment" JSON..= comment) : go s
@@ -133,25 +141,30 @@ instance FromJSON JSONSchema where
       Nothing -> do
         mAny <- o JSON..:? "anyOf"
         case mAny of
-          Just anies -> pure $ ChoiceSchema anies
+          Just anies -> pure $ AnyOfSchema anies
           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
-                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
 
 data ObjectSchema
-  = ObjectKeySchema Text KeyRequirement JSONSchema (Maybe Text)
+  = ObjectKeySchema !Text !KeyRequirement !JSONSchema !(Maybe Text)
   | ObjectAnySchema -- For 'pure'
-  | ObjectChoiceSchema (NonEmpty ObjectSchema)
+  | ObjectAnyOfSchema !(NonEmpty ObjectSchema)
-  | ObjectAllOfSchema (NonEmpty ObjectSchema)
+  | ObjectOneOfSchema !(NonEmpty ObjectSchema)
+  | ObjectAllOfSchema !(NonEmpty ObjectSchema)
   deriving (Show, Eq, Generic)
 
 instance Validity ObjectSchema
@@ -171,26 +184,32 @@ instance FromJSON ObjectSchema where
           Nothing -> do
             mAnyOf <- o JSON..:? "anyOf"
             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
-                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
   toJSON = JSON.object . (("type" JSON..= ("object" :: Text)) :) . go
@@ -202,7 +221,8 @@ instance ToJSON ObjectSchema where
           let (propVal, req) = keySchemaToPieces (k, kr, ks, mDoc)
            in -- TODO deal with the default value somehow.
               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 ->
           case mapM parseAndObjectKeySchema (NE.toList ne) of
             Nothing -> ["allOf" JSON..= NE.map toJSON ne]
@@ -239,7 +259,8 @@ validateAccordingTo val schema = (`evalState` M.empty) $ go val schema
           Optional _ -> pure True
         Just value' -> go value' ks
       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 value = \case
@@ -266,7 +287,8 @@ validateAccordingTo val schema = (`evalState` M.empty) $ go val schema
         JSON.Object obj -> goObject obj os
         _ -> pure False
       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
       RefSchema name -> do
         mSchema <- gets (M.lookup name)
@@ -279,7 +301,7 @@ validateAccordingTo val schema = (`evalState` M.empty) $ go val schema
 
 data KeyRequirement
   = Required
-  | Optional (Maybe JSON.Value) -- Default value
+  | Optional !(Maybe JSON.Value) -- Default value
   deriving (Show, Eq, Generic)
 
 instance Validity KeyRequirement
@@ -306,10 +328,12 @@ jsonSchemaVia = (`evalState` S.empty) . go
       MapCodec c -> MapSchema <$> go c
       ValueCodec -> pure AnySchema
       EqCodec value c -> pure $ ValueSchema (toJSONVia c value)
-      EitherCodec c1 c2 -> do
+      EitherCodec u c1 c2 -> do
         s1 <- go c1
         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
       CommentCodec t c -> CommentSchema t <$> go c
       ReferenceCodec name c -> do
@@ -321,14 +345,23 @@ jsonSchemaVia = (`evalState` S.empty) . go
             s <- go c
             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
-      Just ne -> goSingle s <> goChoice ne
+      Just ne -> goSingle s <> goAnyOf ne
       where
         goSingle :: JSONSchema -> NonEmpty JSONSchema
         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' :| []
 
     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
       OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
       BimapCodec _ _ c -> goObject c
-      EitherCodec oc1 oc2 -> do
+      EitherCodec u oc1 oc2 -> do
         os1 <- goObject oc1
         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
       ApCodec oc1 oc2 -> do
         os1 <- goObject oc1
         os2 <- goObject oc2
         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
-      Just ne -> goSingle s <> goObjectChoice ne
+      Just ne -> goSingle s <> goObjectAnyOf ne
       where
         goSingle :: ObjectSchema -> NonEmpty ObjectSchema
         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' :| []
 
     goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema

autodocodec-swagger2/CHANGELOG.md

@@ -1,5 +1,11 @@
 # Changelog
 
+## [0.0.1.0] - 2021-11-19
+
+### Added
+
+* `disjointEitherCodec` now does not generate `additionalProperties = true`.
+
 ## [0.0.0.0] - 2021-11-19
 
 First release.

autodocodec-swagger2/autodocodec-swagger2.cabal

@@ -1,11 +1,11 @@
 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
 
 name:           autodocodec-swagger2
-version:        0.0.0.0
+version:        0.0.1.0
 synopsis:       Autodocodec interpreters for swagger2
 homepage:       https://github.com/NorfairKing/autodocodec#readme
 bug-reports:    https://github.com/NorfairKing/autodocodec/issues
@@ -34,7 +34,7 @@ library
       src
   build-depends:
       aeson
-    , autodocodec
+    , autodocodec >=0.0.1.0
     , base >=4.7 && <5
     , insert-ordered-containers
     , scientific

autodocodec-swagger2/package.yaml

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

autodocodec-swagger2/src/Autodocodec/Swagger/Schema.hs

@@ -104,12 +104,12 @@ declareNamedSchemaVia c' Proxy = go c'
               { _schemaParamSchema = mempty {_paramSchemaEnum = Just [toJSONVia valCodec val]}
               }
       BimapCodec _ _ c -> go c
-      EitherCodec c1 c2 -> do
+      EitherCodec u c1 c2 -> do
         ns1 <- go c1
         let s1 = _namedSchemaSchema ns1
         ns2 <- go c2
         let s2 = _namedSchemaSchema ns2
-        pure $ NamedSchema Nothing $ combineSchemaOr s1 s2
+        pure $ NamedSchema Nothing $ combineSchemaOr u s1 s2
       CommentCodec t c -> do
         NamedSchema mName s <- go c
         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)
       PureCodec _ -> pure []
-      EitherCodec oc1 oc2 -> do
+      EitherCodec u oc1 oc2 -> do
         ss1 <- goObject oc1
         ss2 <- goObject oc2
-        pure [combineSchemaOr (combineObjectSchemas ss1) (combineObjectSchemas ss2)]
+        pure [combineSchemaOr u (combineObjectSchemas ss1) (combineObjectSchemas ss2)]
       ApCodec oc1 oc2 -> do
         ss1 <- goObject oc1
         ss2 <- goObject oc2
@@ -180,8 +180,8 @@ declareNamedSchemaVia c' Proxy = go c'
         }
     combineObjectSchemas :: [Schema] -> Schema
     combineObjectSchemas = mconcat
-    combineSchemaOr :: Schema -> Schema -> Schema
+    combineSchemaOr :: Union -> Schema -> Schema -> Schema
-    combineSchemaOr s1 s2 =
+    combineSchemaOr u s1 s2 =
       let ps1 = _schemaParamSchema s1
           ps2 = _schemaParamSchema s2
           -- 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.
           overApproximation =
             mempty
-              { _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True
+              { _schemaAdditionalProperties = case u of
+                  PossiblyJointUnion -> Just $ AdditionalPropertiesAllowed True
+                  DisjointUnion -> Nothing
               }
        in case (,) <$> _paramSchemaEnum ps1 <*> _paramSchemaEnum ps2 of
             (Just (es1, es2)) ->

autodocodec-yaml/CHANGELOG.md

@@ -1,5 +1,11 @@
 # 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
 
 First release.

autodocodec-yaml/autodocodec-yaml.cabal

@@ -1,11 +1,11 @@
 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
 
 name:           autodocodec-yaml
-version:        0.0.0.0
+version:        0.0.1.0
 synopsis:       Autodocodec interpreters for yaml
 homepage:       https://github.com/NorfairKing/autodocodec#readme
 bug-reports:    https://github.com/NorfairKing/autodocodec/issues
@@ -35,7 +35,7 @@ library
       src
   build-depends:
       autodocodec
-    , autodocodec-schema
+    , autodocodec-schema >=0.1.0.0
     , base >=4.7 && <5
     , bytestring
     , containers

autodocodec-yaml/package.yaml

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

autodocodec-yaml/src/Autodocodec/Yaml/Encode.hs

@@ -42,7 +42,7 @@ toYamlVia = flip go
       ValueCodec -> yamlValue (a :: JSON.Value)
       EqCodec value c -> go value 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
         Right a2 -> go a2 c2
       CommentCodec _ c -> go a c
@@ -60,7 +60,7 @@ toYamlVia = flip go
           then []
           else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mDoc)
       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
         Right a2 -> goObject a2 c2
       PureCodec _ -> []

autodocodec-yaml/src/Autodocodec/Yaml/Schema.hs

@@ -63,6 +63,20 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
     docToLines :: Text -> [[Chunk]]
     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 = \case
       AnySchema -> [[fore yellow "<any>"]]
@@ -90,20 +104,13 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
         addInFrontOfFirstInList [fore white "<key>", ": "] $ [] : go s
       ObjectSchema os -> goObject os
       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
       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 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 = \case
       ObjectAnySchema -> [["<object>"]]
@@ -121,4 +128,5 @@ jsonSchemaChunks = concatMap (\l -> l ++ ["\n"]) . go
                 prefixLines = ["# ", requirementComment kr] : defaultValueLine ++ maybe [] docToLines mdoc
              in addInFrontOfFirstInList [fore white $ chunk k, ": "] (prefixLines ++ keySchemaChunks)
       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

autodocodec/CHANGELOG.md

@@ -1,5 +1,15 @@
 # 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
 
 First release.

autodocodec/autodocodec.cabal

@@ -1,11 +1,11 @@
 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
 
 name:           autodocodec
-version:        0.0.0.0
+version:        0.0.1.0
 synopsis:       Self-documenting encoder and decoder
 homepage:       https://github.com/NorfairKing/autodocodec#readme
 bug-reports:    https://github.com/NorfairKing/autodocodec/issues

autodocodec/package.yaml

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

autodocodec/src/Autodocodec.hs

@@ -57,25 +57,32 @@ module Autodocodec
     optionalFieldOrNullWithOmittedDefaultWith',
 
     -- ** Writing your own value codecs.
-    maybeCodec,
+
-    eitherCodec,
+    -- *** Primitive codecs
-    listCodec,
-    nonEmptyCodec,
-    singleOrListCodec,
-    singleOrNonEmptyCodec,
-    vectorCodec,
-    valueCodec,
     nullCodec,
     boolCodec,
     textCodec,
     stringCodec,
     scientificCodec,
+    valueCodec,
+
+    -- *** Integral codecs
     boundedIntegralCodec,
     boundedIntegralNumberBounds,
+
+    -- *** Literal value codecs
     literalTextCodec,
     literalTextValueCodec,
-    (<?>),
+
-    (<??>),
+    -- *** Enums
+    shownBoundedEnumCodec,
+    stringConstCodec,
+    enumCodec,
+
+    -- *** Sum type codecs
+    eitherCodec,
+    disjointEitherCodec,
+    possiblyJointEitherCodec,
 
     -- *** Mapping
     dimapCodec,
@@ -83,10 +90,13 @@ module Autodocodec
     rmapCodec,
     lmapCodec,
 
-    -- *** Enums
+    -- *** Composing codecs
-    shownBoundedEnumCodec,
+    maybeCodec,
-    stringConstCodec,
+    listCodec,
-    enumCodec,
+    nonEmptyCodec,
+    singleOrListCodec,
+    singleOrNonEmptyCodec,
+    vectorCodec,
 
     -- *** Alternative parsing
     parseAlternative,
@@ -96,6 +106,10 @@ module Autodocodec
     matchChoiceCodec,
     matchChoicesCodec,
 
+    -- *** Adding documentation to a codec
+    (<?>),
+    (<??>),
+
     -- * Bare codec
     Codec (..),
     ValueCodec,

autodocodec/src/Autodocodec/Aeson/Decode.hs

@@ -88,12 +88,26 @@ parseJSONContextVia codec_ context_ =
         case f old of
           Left err -> fail err
           Right new -> pure new
-      EitherCodec c1 c2 ->
+      EitherCodec u c1 c2 ->
         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
       ReferenceCodec _ c -> go value c
       RequiredKeyCodec k c _ -> do

autodocodec/src/Autodocodec/Aeson/Encode.hs

@@ -41,7 +41,7 @@ toJSONVia = flip go
       ValueCodec -> (a :: JSON.Value)
       EqCodec value c -> go value 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
         Right a2 -> go a2 c2
       CommentCodec _ c -> go a c
@@ -60,7 +60,7 @@ toJSONVia = flip go
           else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
       BimapCodec _ g c -> goObject (g a) c
       PureCodec _ -> mempty
-      EitherCodec c1 c2 -> case (a :: Either _ _) of
+      EitherCodec _ c1 c2 -> case (a :: Either _ _) of
         Left a1 -> goObject a1 c1
         Right a2 -> goObject a2 c2
       ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2
@@ -86,7 +86,7 @@ toEncodingVia = flip go
       ValueCodec -> JSON.value (a :: JSON.Value)
       EqCodec value c -> go value 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
         Right a2 -> go a2 c2
       CommentCodec _ c -> go a c
@@ -104,7 +104,7 @@ toEncodingVia = flip go
           else goObject a (OptionalKeyWithDefaultCodec k c defaultValue mdoc)
       PureCodec _ -> mempty :: JSON.Series
       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
         Right a2 -> goObject a2 c2
       ApCodec oc1 oc2 -> goObject a oc1 <> goObject a oc2

autodocodec/src/Autodocodec/Class.hs

@@ -103,7 +103,7 @@ instance HasCodec a => HasCodec (Maybe a) where
 
 instance (HasCodec l, HasCodec r) => HasCodec (Either l r) where
   codec =
-    eitherCodec
+    disjointEitherCodec
       (ObjectOfCodec Nothing (requiredField' "Left"))
       (ObjectOfCodec Nothing (requiredField' "Right"))
 

autodocodec/src/Autodocodec/Codec.hs

@@ -33,9 +33,10 @@ import qualified Data.Vector as V
 import GHC.Generics (Generic)
 
 -- $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.HashMap.Strict as HM
 -- >>> import Data.Aeson (Value(..))
 -- >>> import qualified Data.Vector as Vector
 -- >>> 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,
   -- because those docs are easier to generate.
   EitherCodec ::
+    -- | What type of union we encode and decode
+    !Union ->
     -- | Codec for the 'Left' side
     (Codec context input1 output1) ->
     -- | Codec for the 'Right' side
@@ -257,6 +260,7 @@ data NumberBounds = NumberBounds
 
 instance Validity NumberBounds
 
+-- | Check if a number falls within given 'NumberBounds'.
 checkNumberBounds :: NumberBounds -> Scientific -> Either String Scientific
 checkNumberBounds NumberBounds {..} 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 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.
 --
 -- 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
       EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec 11 value . showString " " . s) <$> go 11 c
       BimapCodec _ _ c -> (\s -> showParen (d > 10) $ showString "BimapCodec _ _ " . s) <$> go 11 c
-      EitherCodec 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
       ReferenceCodec name c -> do
         alreadySeen <- gets (S.member name)
@@ -438,7 +452,11 @@ instance Applicative (ObjectCodec input) where
 -- >>> toJSONVia (maybeCodec codec) (Nothing :: Maybe Char)
 -- Null
 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
     f = \case
       Left () -> Nothing
@@ -449,19 +467,113 @@ maybeCodec = dimapCodec f g . EitherCodec nullCodec
 
 -- | Forward-compatible version of 'EitherCodec'
 --
--- > eitherCodec = EitherCodec
+-- > eitherCodec = EitherCodec PossiblyJointUnion
 --
 -- === '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:
 --
--- >>> 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
 --    codec =
 --      dimapCodec f g $
---        eitherCodec
+--        disjointEitherCodec
 --          (codec :: JSONCodec Word8)
 --          (codec :: JSONCodec Text)
 --      where
@@ -473,22 +585,46 @@ maybeCodec = dimapCodec f g . EitherCodec nullCodec
 --          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)
 -- Number 2.0
 -- >>> toJSONViaCodec (OtherWar "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
 --
--- >>> toJSONVia (eitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)
+-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)
 -- 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"
-eitherCodec ::
+disjointEitherCodec ::
+  -- |
   Codec context input1 output1 ->
+  -- |
   Codec context input2 output2 ->
+  -- |
   Codec context (Either input1 input2) (Either output1 output2)
-eitherCodec = EitherCodec
+disjointEitherCodec = EitherCodec DisjointUnion
 
 -- | Map a codec's input and output types.
 --