NorfairKing/autodocodec
1
1
Fork 0
mirror of https://github.com/NorfairKing/autodocodec.git synced 2024-11-22 04:43:15 +03:00
Code Issues Projects Releases Wiki Activity

further improved handling of eitherCodec in objectCodec

Browse Source
This commit is contained in:
Tom Sydney Kerckhove 2024-11-04 10:27:13 +01:00
parent a7488a3303
commit e939442995
23 changed files with 340 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -73,6 +73,7 @@ extra-source-files:
test_resources/json-schema/null.json
test_resources/json-schema/object.json
test_resources/json-schema/ordering.json
test_resources/json-schema/overlap.json
test_resources/json-schema/recursive.json
test_resources/json-schema/scientific.json
test_resources/json-schema/semigroup-first.json
@ -140,6 +141,8 @@ extra-source-files:
test_resources/nix/null-type.nix
test_resources/nix/object-type.nix
test_resources/nix/ordering-type.nix
test_resources/nix/overlap-options.nix
test_resources/nix/overlap-type.nix
test_resources/nix/recursive-type.nix
test_resources/nix/scientific-type.nix
test_resources/nix/semigroup-first-type.nix
@ -225,6 +228,7 @@ extra-source-files:
test_resources/openapi-schema/null.json
test_resources/openapi-schema/object.json
test_resources/openapi-schema/ordering.json
test_resources/openapi-schema/overlap.json
test_resources/openapi-schema/recursive.json
test_resources/openapi-schema/scientific.json
test_resources/openapi-schema/semigroup-first.json
@ -284,6 +288,7 @@ extra-source-files:
test_resources/show-codec/null.txt
test_resources/show-codec/object.txt
test_resources/show-codec/ordering.txt
test_resources/show-codec/overlap.txt
test_resources/show-codec/recursive.txt
test_resources/show-codec/scientific.txt
test_resources/show-codec/semigroup-first.txt
@ -346,6 +351,7 @@ extra-source-files:
test_resources/swagger-schema/null.json
test_resources/swagger-schema/object.json
test_resources/swagger-schema/ordering.json
test_resources/swagger-schema/overlap.json
test_resources/swagger-schema/recursive.json
test_resources/swagger-schema/scientific.json
test_resources/swagger-schema/semigroup-first.json
@ -402,6 +408,7 @@ extra-source-files:
test_resources/yaml-schema/null.txt
test_resources/yaml-schema/object.txt
test_resources/yaml-schema/ordering.txt
test_resources/yaml-schema/overlap.txt
test_resources/yaml-schema/recursive.txt
test_resources/yaml-schema/scientific.txt
test_resources/yaml-schema/set-text.txt

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

@ -776,3 +776,54 @@ newtype NonOrphanExample = NonOrphanExample Example
deriving newtype (HasCodec)
deriving (OpenAPI.ToSchema) via (AutodocodecOpenApi NonOrphanExample)
deriving (Swagger.ToSchema) via (AutodocodecSwagger NonOrphanExample)
data Overlap
= OverlapA !Text
| OverlapB !Int
deriving (Show, Eq, Generic)
deriving (FromJSON, ToJSON) via Autodocodec Overlap
deriving
( Servant.FromMultipart tag,
Servant.ToMultipart tag
)
via Autodocodec Overlap
deriving (OpenAPI.ToSchema) via (AutodocodecOpenApi Overlap)
deriving (Swagger.ToSchema) via (AutodocodecSwagger Overlap)
instance Validity Overlap
instance GenValid Overlap where
genValid = genValidStructurallyWithoutExtraChecking
shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
instance HasCodec Overlap where
codec =
dimapCodec f g $
eitherCodec
(object "A" (typeField "a" () *> requiredField "text" "text for a"))
(object "B" (typeField "b" () *> requiredField "int" "int for b"))
where
f = \case
Left s -> OverlapA s
Right i -> OverlapB i
g = \case
OverlapA s -> Left s
OverlapB i -> Right i
instance HasObjectCodec Overlap where
objectCodec =
dimapCodec f g $
eitherCodec
(typeField "a" () *> requiredField "string" "string for a")
(typeField "b" () *> requiredField "int" "int for b")
where
f = \case
Left s -> OverlapA s
Right i -> OverlapB i
g = \case
OverlapA s -> Left s
OverlapB i -> Right i
typeField :: Text -> a -> ObjectCodec b a
typeField typeName a =
a <$ requiredFieldWith' "type" (literalTextCodec typeName) .= const typeName

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

@ -105,6 +105,7 @@ spec = do
jsonSchemaSpec @(Monoid.First Text) "monoid-first"
jsonSchemaSpec @(Monoid.Last Text) "monoid-last"
jsonSchemaSpec @(Const Text Void) "const"
jsonSchemaSpec @Overlap "overlap"
describe "JSONSchema" $ do
genValidSpec @JSONSchema

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

@ -123,6 +123,7 @@ spec = do
aesonCodecSpec @(Monoid.First Text)
aesonCodecSpec @(Monoid.Last Text)
aesonCodecSpec @(Const Text Void)
aesonCodecSpec @Overlap
aesonCodecErrorSpec ::
forall a.

1
autodocodec-api-usage/test/Autodocodec/MultipartSpec.hs
View File

@ -40,6 +40,7 @@ spec = do
multipartCodecSpec @These
multipartCodecSpec @Expression
multipartCodecSpec @ListsExample
multipartCodecSpec @Overlap
multipartCodecSpec ::
forall a.

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

@ -102,6 +102,8 @@ spec = do
nixOptionTypeSpec @(Monoid.First Text) "monoid-first"
nixOptionTypeSpec @(Monoid.Last Text) "monoid-last"
nixOptionTypeSpec @(Const Text Void) "const"
nixOptionTypeSpec @Overlap "overlap"
nixOptionsSpec @Overlap "overlap"
nixOptionsSpec ::
forall a.

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

@ -130,6 +130,7 @@ spec = do
openAPISchemaSpecAndViaDeclareSchemaRef @(Monoid.First Text) "monoid-first"
openAPISchemaSpecAndViaDeclareSchemaRef @(Monoid.Last Text) "monoid-last"
openAPISchemaSpecAndViaDeclareSchemaRef @(Const Text Void) "const"
openAPISchemaSpec @Overlap "overlap"
openAPISchemaSpec :: forall a. (Typeable a, HasCodec a) => FilePath -> Spec
openAPISchemaSpec filePath =

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

@ -94,6 +94,7 @@ spec = do
showCodecSpec @(Monoid.First Text) "monoid-first"
showCodecSpec @(Monoid.Last Text) "monoid-last"
showCodecSpec @(Const Text Void) "const"
showCodecSpec @Overlap "overlap"
showCodecSpec ::
forall a.

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

@ -112,6 +112,7 @@ spec = do
swaggerSchemaSpec @(Monoid.First Text) "monoid-first"
swaggerSchemaSpec @(Monoid.Last Text) "monoid-last"
swaggerSchemaSpec @(Const Text Void) "const"
xdescribe "does not hold because of overlap" $ swaggerSchemaSpec @Overlap "overlap"
swaggerSchemaSpec :: forall a. (Show a, Typeable a, GenValid a, HasCodec a) => FilePath -> Spec
swaggerSchemaSpec filePath =

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

@ -80,6 +80,7 @@ spec = do
yamlSchemaSpec @These "these"
yamlSchemaSpec @Expression "expression"
yamlSchemaSpec @MultilineDefault "multiline-default"
yamlSchemaSpec @Overlap "overlap"
yamlSchemaSpec ::
forall a.

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

@ -103,6 +103,7 @@ spec = do
yamlCodecSpec @(Monoid.First Text)
yamlCodecSpec @(Monoid.Last Text)
yamlCodecSpec @(Const Text Void)
yamlCodecSpec @Overlap
yamlCodecSpec ::
forall a.

40
autodocodec-api-usage/test_resources/json-schema/overlap.json Normal file
View File

@ -0,0 +1,40 @@
{
"anyOf": [
{
"$comment": "A",
"properties": {
"text": {
"$comment": "text for a",
"type": "string"
},
"type": {
"const": "a"
}
},
"required": [
"text",
"type"
],
"type": "object"
},
{
"$comment": "B",
"properties": {
"int": {
"$comment": "int for b",
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "integer"
},
"type": {
"const": "b"
}
},
"required": [
"int",
"type"
],
"type": "object"
}
]
}

20
autodocodec-api-usage/test_resources/nix/overlap-options.nix Normal file
View File

@ -0,0 +1,20 @@
{ lib }:
{
int = lib.mkOption {
default = null;
description = "int for b";
type = lib.types.nullOr lib.types.int;
};
string = lib.mkOption {
default = null;
description = "string for a";
type = lib.types.nullOr lib.types.str;
};
type = lib.mkOption {
default = null;
type = lib.types.nullOr (lib.types.enum [
"a"
"b"
]);
};
}

25
autodocodec-api-usage/test_resources/nix/overlap-type.nix Normal file
View File

@ -0,0 +1,25 @@
{ lib }:
lib.types.oneOf [
(lib.types.submodule {
options = {
text = lib.mkOption {
description = "text for a";
type = lib.types.str;
};
type = lib.mkOption {
type = lib.types.enum ["a"];
};
};
})
(lib.types.submodule {
options = {
int = lib.mkOption {
description = "int for b";
type = lib.types.int;
};
type = lib.mkOption {
type = lib.types.enum ["b"];
};
};
})
]

63
autodocodec-api-usage/test_resources/openapi-schema/overlap.json Normal file
View File

@ -0,0 +1,63 @@
{
"components": {
"schemas": {
"A": {
"properties": {
"text": {
"description": "text for a",
"type": "string"
},
"type": {
"enum": [
"a"
],
"type": "string"
}
},
"required": [
"type",
"text"
],
"type": "object"
},
"B": {
"properties": {
"int": {
"description": "int for b",
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "integer"
},
"type": {
"enum": [
"b"
],
"type": "string"
}
},
"required": [
"type",
"int"
],
"type": "object"
},
"Overlap": {
"additionalProperties": true,
"anyOf": [
{
"$ref": "#/components/schemas/A"
},
{
"$ref": "#/components/schemas/B"
}
]
}
}
},
"info": {
"title": "",
"version": ""
},
"openapi": "3.0.0",
"paths": {}
}

35
autodocodec-api-usage/test_resources/show-codec/overlap.txt Normal file
View File

@ -0,0 +1,35 @@
BimapCodec
_
_
(EitherCodec
PossiblyJointUnion
(ObjectOfCodec
(Just "A")
(ApCodec
(BimapCodec
_
_
(RequiredKeyCodec
"type" Nothing (EqCodec "a" (StringCodec Nothing))))
(RequiredKeyCodec
"text" (Just "text for a") (StringCodec Nothing))))
(ObjectOfCodec
(Just "B")
(ApCodec
(BimapCodec
_
_
(RequiredKeyCodec
"type" Nothing (EqCodec "b" (StringCodec Nothing))))
(RequiredKeyCodec
"int"
(Just "int for b")
(BimapCodec
_
_
(IntegerCodec
Nothing
Bounds
{ boundsLower = Just (-9223372036854775808)
, boundsUpper = Just 9223372036854775807
}))))))

33
autodocodec-api-usage/test_resources/swagger-schema/overlap.json Normal file
View File

@ -0,0 +1,33 @@
{
"definitions": {
"Overlap": {
"properties": {
"int": {
"description": "int for b",
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "integer"
},
"text": {
"description": "text for a",
"type": "string"
},
"type": {
"enum": [
"a"
]
}
},
"required": [
"type"
],
"type": "object"
}
},
"info": {
"title": "",
"version": ""
},
"paths": {},
"swagger": "2.0"
}

14
autodocodec-api-usage/test_resources/yaml-schema/overlap.txt Normal file
View File

@ -0,0 +1,14 @@
# any of
[ # A
type: # required
a
text: # required
# text for a
<string>
, # B
type: # required
b
int: # required
# int for b
<integer> # 64 bit signed integer
]

7
autodocodec-nix/CHANGELOG.md
View File

@ -1,5 +1,12 @@
# Changelog
## [0.0.1.5] - 2024-11-04
### Changed
* More accurate support for `EitherCodec` in `ObjectCodec`s.
Options' types in an object are now or-ed.
## [0.0.1.4] - 2024-08-22
### Changed

2
autodocodec-nix/autodocodec-nix.cabal
View File

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: autodocodec-nix
version: 0.0.1.4
version: 0.0.1.5
synopsis: Autodocodec interpreters for nix
homepage: https://github.com/NorfairKing/autodocodec#readme
bug-reports: https://github.com/NorfairKing/autodocodec/issues

2
autodocodec-nix/default.nix
View File

@ -3,7 +3,7 @@
}:
mkDerivation {
pname = "autodocodec-nix";
version = "0.0.1.4";
version = "0.0.1.5";
src = ./.;
libraryHaskellDepends = [
aeson autodocodec base containers scientific text

2
autodocodec-nix/package.yaml
View File

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

36
autodocodec-nix/src/Autodocodec/Nix.hs
View File

@ -169,9 +169,25 @@ objectCodecNixOptions = simplifyOptions . go False
optionDefault = Just $ toJSONVia c defaultValue
}
PureCodec _ -> M.empty
ApCodec c1 c2 -> M.union (go b c1) (go b c2)
ApCodec c1 c2 -> M.unionWith mergeOption (go b c1) (go b c2)
BimapCodec _ _ c -> go b c
EitherCodec _ c1 c2 -> M.union (go True c1) (go True c2) -- TODO use a more accurate or?
EitherCodec _ c1 c2 -> M.unionWith mergeOption (go True c1) (go True c2)
-- This throwing away of the description and the default is not ideal but
-- better than just taking the first option.
mergeOption :: Option -> Option -> Option
mergeOption o1 o2 =
o1
{ optionType =
( \ot1 ot2 ->
simplifyOptionType $
OptionTypeOneOf
[ ot1,
ot2
]
)
<$> optionType o1
<*> optionType o2
}
data Option = Option
{ optionType :: !(Maybe OptionType),
@ -219,13 +235,25 @@ simplifyOptionType = go
OptionTypeOneOf os -> case goEnums $ nubOrd $ concatMap goOr os of
[ot] -> ot
os' ->
if OptionTypeNull `elem` os'
then go $ OptionTypeNullOr $ case filter (/= OptionTypeNull) os' of
if any canBeNull os'
then go $ OptionTypeNullOr $ case mapMaybe stripNull os' of
[t] -> t
ts' -> OptionTypeOneOf ts'
else OptionTypeOneOf os'
OptionTypeSubmodule m -> OptionTypeSubmodule $ M.map goOpt m
canBeNull :: OptionType -> Bool
canBeNull = \case
OptionTypeNull -> True
OptionTypeNullOr _ -> True
_ -> False
stripNull :: OptionType -> Maybe OptionType
stripNull = \case
OptionTypeNull -> Nothing
OptionTypeNullOr t -> Just t
t -> Just t
goEnums :: [OptionType] -> [OptionType]
goEnums = goEnum []
where