diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. +## 2.0.0.0 + +- Bumped the epoch major version to align with `json-spec` 2.0.0.0. +- Adapted to `json-spec` 2.0.0.0, including support for modules, module + bindings (`::=`), type bindings (`:=`), and closed scoping during + schema generation and symbol renaming. + ## 1.3.0.1 - Support `aeson` 2.3. diff --git a/json-spec-openapi.cabal b/json-spec-openapi.cabal --- a/json-spec-openapi.cabal +++ b/json-spec-openapi.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec-openapi -version: 1.3.0.1 +version: 2.0.0.0 synopsis: json-spec-openapi description: This package provides a way to produce @@ -19,14 +19,11 @@ > deriving ToSchema via (EncodingSchema User) -- <-- ToSchema instance defined here > instance HasJsonEncodingSpec User where > type EncodingSpec User = - > JsonObject - > '[ Required "name" JsonString - > , Optional "last-login" JsonDateTime - > ] - > toJSONStructure user = - > (Field @"name" (name user), - > (fmap (Field @"last-login") (lastLogin user), - > ())) + > 'Module + > (JsonObject + > '[ Required "name" JsonString + > , Optional "last-login" JsonDateTime + > ]) Calling `Data.Aeson.encode (Data.OpenApi3.toSchema (Proxy :: Proxy User))` will produce the following Schema: @@ -64,7 +61,7 @@ build-depends: , aeson >= 2.2.1.0 && < 2.4 , base >= 4.19.2.0 && < 4.23 - , json-spec >= 1.4.0.0 && < 1.5 + , json-spec >= 2.0.0.0 && < 2.1 , lens >= 5.2.3 && < 5.4 , openapi3 >= 3.2.5 && < 3.3 , text >= 2.1 && < 2.2 diff --git a/src/Data/JsonSpec/OpenApi.hs b/src/Data/JsonSpec/OpenApi.hs --- a/src/Data/JsonSpec/OpenApi.hs +++ b/src/Data/JsonSpec/OpenApi.hs @@ -32,14 +32,11 @@ > deriving ToSchema via (EncodingSchema User) -- <-- ToSchema instance defined here > instance HasJsonEncodingSpec User where > type EncodingSpec User = - > JsonObject - > '[ Required "name" JsonString - > , Optional "last-login" JsonDateTime - > ] - > toJSONStructure user = - > (Field @"name" (name user), - > (fmap (Field @"last-login") (lastLogin user), - > ())) + > 'Module + > (JsonObject + > '[ Required "name" JsonString + > , Optional "last-login" JsonDateTime + > ]) Calling @'Data.Aeson.encode' ('Data.OpenApi3.toSchema' ('Proxy' :: 'Proxy' User))@ will produce the following Schema: @@ -71,21 +68,18 @@ > } > instance HasJsonEncodingSpec User where > type EncodingSpec User = - > JsonObject - > '[ Required "name" JsonString - > , Optional "last-login" JsonDateTime - > ] - > toJSONStructure user = - > (Field @"name" (name user), - > (fmap (Field @"last-login") (lastLogin user), - > ())) + > 'Module + > (JsonObject + > '[ Required "name" JsonString + > , Optional "last-login" JsonDateTime + > ]) > instance ToSchema User where > declareNamedSchema _proxy = > pure $ > NamedSchema > Nothing > ( - > toOpenApiSchema (EncodingSpec User) + > toOpenApiSchema (Proxy @(EncodingSpec User)) > & set > additionalProperties > (Just (AdditionalPropertiesAllowed True)) @@ -109,14 +103,14 @@ Example (you may need @-XFlexibleInstances@ for the instance): > data AnnotatedUser = AnnotatedUser { name_ :: Text, age_ :: Int } - > deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedUser) + > deriving (ToJSON, FromJSON) via (SpecJson AnnotatedUser) > instance SchemaModifier AnnotatedUser where > modifySchema s = s & set description (Just \"A user with name and age\") > instance HasJsonEncodingSpec AnnotatedUser where > type EncodingSpec AnnotatedUser = - > JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ] - > (JsonObject '[ Required \"name\" JsonString, Required \"age\" JsonInt ]) - > toJSONStructure (AnnotatedUser n a) = (Field @"name" n, (Field @"age" a, ())) + > 'Module + > (JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ] + > (JsonObject '[ Required \"name\" JsonString, Required \"age\" JsonInt ])) The type in @\"schema-modifier\"@ must have a 'SchemaModifier' instance or you get a type error; it is not ignored. @@ -135,12 +129,13 @@ import Data.Aeson (ToJSON(toJSON)) import Data.Functor.Identity (Identity(runIdentity)) import Data.JsonSpec - ( FieldSpec(Optional, Required), HasJsonDecodingSpec(DecodingSpec) - , HasJsonEncodingSpec(EncodingSpec) + ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required) + , HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec) + , Module(Module) , Specification ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither - , JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef - , JsonString, JsonTag + , JsonInt, JsonLet, JsonModule, JsonNullable, JsonNum, JsonObject, JsonRaw + , JsonRef, JsonString, JsonTag ) ) import Data.JsonSpec.OpenApi.Rename (Rename) @@ -173,9 +168,9 @@ import qualified GHC.TypeError as TE {-| - Convert a 'Specification' into an OpenApi 'Schema'. The type class - 'Schemaable' is an internal and opaque implementation detail and not - something you should have to worry about. + Convert a 'Specification' or closed 'Module' into an OpenApi 'Schema'. + The type class 'Schemaable' is an internal and opaque implementation + detail and not something you should have to worry about. It should already have an instance for every 'Specification' that can be turned into a 'Schema'. If it does not, then that is a bug. Please @@ -187,7 +182,7 @@ of the form: > JsonLet '[ - > '("foo", ...) + > "foo" := ... > ] ( > JsonRef "foo" > ) @@ -199,7 +194,7 @@ > toOpenApiSchema (Proxy @( > JsonLet - > '[ '("foo", JsonString) ] + > '[ "foo" := JsonString ] > (JsonRef "foo") > )) @@ -207,7 +202,7 @@ > toOpenApiSchema (Proxy @( > JsonLet - > '[ '("foo", JsonString) ] + > '[ "foo" := JsonString ] > JsonString > )) @@ -223,7 +218,7 @@ > toOpenApiSchema > (Proxy @( > JsonObject '[ - > ("bar", JsonRef "not-defined") + > Required "bar" (JsonRef "not-defined") > ] > )) > in @@ -260,6 +255,7 @@ instance (Inlineable '[] spec) => Schemaable spec where schemaable = inlineable @'[] @spec + class Inlineable (defs :: [ (Symbol, Specification) ]) @@ -378,15 +374,17 @@ mempty & set type_ (Just OpenApiObject) instance {- Inlineable defs (JsonLet newDefs spec) -} - ( Inlineable (Concat newDefs defs) spec - , Defs (Concat newDefs defs) newDefs + ( Inlineable (Concat (BindingsToFrame newDefs) defs) spec + , Defs (Concat (BindingsToFrame newDefs) defs) newDefs ) => Inlineable defs (JsonLet newDefs spec) where inlineable = do - mkDefs @(Concat newDefs defs) @newDefs - inlineable @(Concat newDefs defs) @spec + mkDefs @(Concat (BindingsToFrame newDefs) defs) @newDefs + inlineable @(Concat (BindingsToFrame newDefs) defs) @spec +instance (Inlineable '[] spec) => Inlineable defs (JsonModule ('Module spec)) where + inlineable = inlineable @'[] @spec instance {- Inlineable defs (JsonRef target) -} ( Deref defs defs target ) @@ -446,15 +444,15 @@ instance {-# overlappable #-} (Inlineable defs a) => Refable defs a where refable = fmap Inline (inlineable @defs @a) instance - ( Defs newDefs newDefs - , Refable (Concat newDefs defs) spec + ( Defs (BindingsToFrame newDefs) newDefs + , Refable (Concat (BindingsToFrame newDefs) defs) spec ) => Refable defs (JsonLet newDefs spec) where refable = do - mkDefs @newDefs @newDefs - refable @(Concat newDefs defs) @spec + mkDefs @(BindingsToFrame newDefs) @newDefs + refable @(Concat (BindingsToFrame newDefs) defs) @spec instance (KnownSymbol name) => Refable defs (JsonRef name) where refable = pure (ref (sym @name)) @@ -500,25 +498,37 @@ class Defs (allDefs :: [(Symbol, Specification)]) - (defs :: [(Symbol, Specification)]) + (defs :: [BindingSpec]) where mkDefs :: (MonadDeclare (Definitions Schema) m) => m () instance Defs defs '[] where mkDefs = pure () -instance {- Defs defs ( '(name, spec) ': more) -} +instance {- Defs defs (TypeBind name spec ': more) -} ( Defs defs more , Inlineable defs spec , KnownSymbol name ) => - Defs defs ( '(name, spec) ': more) + Defs defs (TypeBind name spec ': more) where mkDefs = do schema <- inlineable @defs @spec declare (HMI.singleton (sym @name) schema) mkDefs @defs @more +instance {- Defs defs (ModuleBind name ('Module spec) ': more) -} + ( Defs defs more + , Inlineable '[] spec + , KnownSymbol name + ) + => + Defs defs (ModuleBind name ('Module spec) ': more) + where + mkDefs = do + schema <- inlineable @'[] @spec + declare (HMI.singleton (sym @name) schema) + mkDefs @defs @more {-| @@ -535,14 +545,16 @@ newtype EncodingSchema a = EncodingSchema {unEncodingSchema :: a} instance - ( Schemaable (EncodingSpec a) + ( Schemaable (JsonModule (EncodingSpec a)) , Typeable a ) => ToSchema (EncodingSchema a) where declareNamedSchema _ = do - let (declarations, schema) = toOpenApiSchema (Proxy @(EncodingSpec a)) + let + (declarations, schema) = + toOpenApiSchema (Proxy @(JsonModule (EncodingSpec a))) declare declarations pure (NamedSchema Nothing schema) @@ -561,14 +573,16 @@ newtype DecodingSchema a = DecodingSchema {unDecodingSchema :: a} instance - ( Schemaable (DecodingSpec a) + ( Schemaable (JsonModule (DecodingSpec a)) , Typeable a ) => ToSchema (DecodingSchema a) where declareNamedSchema _ = do - let (declarations, schema) = toOpenApiSchema (Proxy @(DecodingSpec a)) + let + (declarations, schema) = + toOpenApiSchema (Proxy @(JsonModule (DecodingSpec a))) declare declarations pure (NamedSchema Nothing schema) @@ -587,6 +601,15 @@ ref = OA.Ref . Reference +{-| Lower 'BindingSpec's to the env-frame representation. -} +type family BindingsToFrame (bs :: [BindingSpec]) :: [(Symbol, Specification)] where + BindingsToFrame '[] = '[] + BindingsToFrame (TypeBind n s : more) = + '(n, s) : BindingsToFrame more + BindingsToFrame (ModuleBind n s : more) = + '(n, JsonModule s) : BindingsToFrame more + + type family Concat (a :: [(Symbol, Specification)]) @@ -646,8 +669,9 @@ Example (you may need @-XFlexibleInstances@ for the instance): > type EncodingSpec AnnotatedUser = - > JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ] - > (JsonObject ...) + > 'Module + > (JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ] + > (JsonObject ...)) > instance SchemaModifier AnnotatedUser where > modifySchema schema = schema & set description (Just \"A user\") -} diff --git a/src/Data/JsonSpec/OpenApi/Rename.hs b/src/Data/JsonSpec/OpenApi/Rename.hs --- a/src/Data/JsonSpec/OpenApi/Rename.hs +++ b/src/Data/JsonSpec/OpenApi/Rename.hs @@ -9,14 +9,16 @@ ) where import Data.JsonSpec - ( FieldSpec(Optional, Required) + ( BindingSpec(ModuleBind, TypeBind), FieldSpec(Optional, Required) + , Module(Module) , Specification ( JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither, JsonInt, JsonLet - , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag + , JsonModule, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef + , JsonString, JsonTag ) ) import GHC.TypeError (ErrorMessage((:$$:))) -import GHC.TypeLits (type (+), AppendSymbol, Nat, Symbol) +import GHC.TypeLits (AppendSymbol, Nat, Symbol, type (+)) import qualified GHC.TypeError as TE {-| @@ -46,17 +48,20 @@ For instance, this 'Specification' will fail to rename properly: > JsonLet - > '[ '("foo", JsonString) - > , '("foo.1", JsonString) + > '[ "foo" := JsonString + > , "foo.1" := JsonString > ] > ( JsonObject > '[ "field1" ::: JsonRef "foo" - > , "field2" ::: JsonLet '[ '("foo", JsonInt)] (JsonRef "foo") + > , "field2" ::: JsonLet '[ "foo" := JsonInt] (JsonRef "foo") > ] > ) because the "foo" in "field2" will be renamed to "foo.1", causing a new conflict with the existing "foo.1". + + Closed 'ModuleBind' / 'JsonModule' bodies are renamed with a fresh + active environment, matching their closed scoping rules. -} type family Rename (spec :: Specification) :: Specification where Rename spec = @@ -132,6 +137,9 @@ defs spec + FoldRename global active (JsonModule ('Module spec)) = + MapJsonModule (FoldRename global (A '[]) spec) + FoldRename global (A active) (JsonRef name) = '(JsonRef (LookupNewName name active), global) @@ -246,14 +254,18 @@ type family UpdateGlobals (global :: Global) - ( defs :: [(Symbol, Specification)]) + ( defs :: [BindingSpec]) :: Global where UpdateGlobals global '[] = global - UpdateGlobals (G global) ( '(name, spec) : more) = + UpdateGlobals (G global) (TypeBind name _spec : more) = UpdateGlobals (G (IncrementName global name)) more + UpdateGlobals (G global) (ModuleBind name _m : more) = + UpdateGlobals + (G (IncrementName global name)) + more type family @@ -273,7 +285,7 @@ RenameLet (global :: Global) -- updated (active :: Active) - (defs :: [(Symbol, Specification)]) + (defs :: [BindingSpec]) (spec :: Specification) :: (Specification, Global) where @@ -289,7 +301,7 @@ RenameLet2 (global :: Global) -- updated (active :: Active) -- updated - (defs :: [(Symbol, Specification)]) + (defs :: [BindingSpec]) (spec :: Specification) where RenameLet2 global active defs spec = @@ -304,7 +316,7 @@ RenameLet3 (global :: Global) (active :: Active) - ( defs :: [(Symbol, Specification)]) + ( defs :: [BindingSpec]) ( spec :: Specification) :: (Specification, Global) where @@ -317,7 +329,7 @@ type family RenameLet4 - ( r :: (Global, [(Symbol, Specification)])) + ( r :: (Global, [BindingSpec])) (active :: Active) ( spec :: Specification) :: (Specification, Global) @@ -331,7 +343,7 @@ type family RenameLet5 (r :: (Specification, Global)) - (defs :: [(Symbol, Specification)]) + (defs :: [BindingSpec]) :: (Specification, Global) where RenameLet5 '(spec, global) defs = @@ -342,15 +354,20 @@ UpdateActives (global :: Global) -- already updated (active :: Active) - ( defs :: [(Symbol, Specification)]) + ( defs :: [BindingSpec]) :: Active where UpdateActives global active '[] = active - UpdateActives global (A active) ( '(name, spec) : more) = + UpdateActives global (A active) (TypeBind name _spec : more) = UpdateActives global (A (SetActive global active name)) more + UpdateActives global (A active) (ModuleBind name _m : more) = + UpdateActives + global + (A (SetActive global active name)) + more type family @@ -390,8 +407,8 @@ ReflectDefs (global :: Global) (active :: Active) - ( defs :: [(Symbol, Specification)]) - :: (Global, [(Symbol, Specification)]) + ( defs :: [BindingSpec]) + :: (Global, [BindingSpec]) where ReflectDefs global active defs = FoldReflectDefs '(global, '[]) active defs @@ -399,48 +416,79 @@ type family FoldReflectDefs - (acc :: (Global, [(Symbol, Specification)])) + (acc :: (Global, [BindingSpec])) (active :: Active) - (defs :: [(Symbol, Specification)]) - :: (Global, [(Symbol, Specification)]) + (defs :: [BindingSpec]) + :: (Global, [BindingSpec]) where FoldReflectDefs acc active '[] = acc FoldReflectDefs '(global, acc) active - ( '(name, spec) : more ) + (TypeBind name spec : more) = - FoldReflectDefs2 + FoldReflectTypeBind (FoldRename global active spec) active name acc more + FoldReflectDefs + '(global, acc) + active + (ModuleBind name ('Module spec) : more) + = + FoldReflectModuleBind + (FoldRename global (A '[]) spec) + active + name + acc + more type family - FoldReflectDefs2 + FoldReflectTypeBind ( spec :: (Specification, Global)) (active :: Active) ( name :: Symbol) - ( acc :: [(Symbol, Specification)]) - ( more :: [(Symbol, Specification)]) - :: (Global, [(Symbol, Specification)]) + ( acc :: [BindingSpec]) + ( more :: [BindingSpec]) + :: (Global, [BindingSpec]) where - FoldReflectDefs2 '(spec, global) active name acc more = - FoldReflectDefs '(global, '(name, spec) : acc) active more + FoldReflectTypeBind '(spec, global) active name acc more = + FoldReflectDefs '(global, TypeBind name spec : acc) active more +type family + FoldReflectModuleBind + ( spec :: (Specification, Global)) + (active :: Active) + ( name :: Symbol) + ( acc :: [BindingSpec]) + ( more :: [BindingSpec]) + :: (Global, [BindingSpec]) + where + FoldReflectModuleBind '(spec, global) active name acc more = + FoldReflectDefs + '(global, ModuleBind name ('Module spec) : acc) + active + more + + {-| Update the LHS of the definitions, to match the already updated globals -} type family RenameDefs (global :: Global) - ( defs :: [(Symbol, Specification)]) - :: [(Symbol, Specification)] + ( defs :: [BindingSpec]) + :: [BindingSpec] where RenameDefs globals '[] = '[] - RenameDefs (G globals) ( '(name, spec) : more) = - '(LookupNewName name globals, spec) : RenameDefs (G globals) more + RenameDefs (G globals) (TypeBind name spec : more) = + TypeBind (LookupNewName name globals) spec + : RenameDefs (G globals) more + RenameDefs (G globals) (ModuleBind name m : more) = + ModuleBind (LookupNewName name globals) m + : RenameDefs (G globals) more type family @@ -585,6 +633,15 @@ :: (Specification, Global) where MapSpec f '(a, b) = '(f a, b) + + +type family + MapJsonModule + (a :: (Specification, Global)) + :: (Specification, Global) + where + MapJsonModule '(spec, global) = + '(JsonModule ('Module spec), global) type family diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -17,16 +17,19 @@ import Control.Lens (At(at), (&), set) import Data.Aeson (ToJSON(toJSON), FromJSON) import Data.JsonSpec - ( Field(Field), FieldSpec(Optional, Required) - , HasJsonDecodingSpec(DecodingSpec, fromJSONStructure) - , HasJsonEncodingSpec(EncodingSpec, toJSONStructure), SpecJSON(SpecJSON) + ( FieldSpec(Optional, Required), HasJsonDecodingSpec(DecodingSpec) + , HasJsonEncodingSpec(EncodingSpec), Module(Module) , Specification ( JsonAnnotated, JsonArray, JsonBool, JsonDateTime, JsonDict, JsonEither - , JsonInt, JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef - , JsonString, JsonTag + , JsonInt, JsonLet, JsonModule, JsonNullable, JsonNum, JsonObject, JsonRaw + , JsonRef, JsonString, JsonTag ) - , (:::), (::?), unField + , type (:::), type (::=), type (::?), type (:=) ) +import Data.JsonSpec.Codec.Tuple + ( Field(Field), SpecJson(SpecJson), TupleDecoding(fromJsonStructure) + , TupleEncoding(toJsonStructure), unField + ) import Data.JsonSpec.OpenApi ( SchemaModifier(modifySchema), EncodingSchema, Rename, toOpenApiSchema ) @@ -314,7 +317,7 @@ actual = toOpenApiSchema (Proxy @( JsonLet '[ - '("thing", JsonString) + "thing" := JsonString ] ( JsonObject '[ @@ -346,12 +349,8 @@ actual = toOpenApiSchema (Proxy @( JsonLet - '[ '( "thing1" - , JsonString - ) - , '( "thing2" - , JsonRef "thing1" - ) + '[ "thing1" := JsonString + , "thing2" := JsonRef "thing1" ] ( JsonRef "thing2" @@ -375,8 +374,8 @@ actual = toOpenApiSchema (Proxy @( JsonLet '[ - '("foo", JsonNum), - '("bar", JsonString) + "foo" := JsonNum, + "bar" := JsonString ] (JsonRef "bar") )) @@ -397,7 +396,7 @@ JsonObject '[ Required "foo" ( JsonLet - '[ '("thing", JsonString)] + '[ "thing" := JsonString ] (JsonRef "thing") ) ] @@ -504,18 +503,14 @@ actual = toOpenApiSchema (Proxy @( JsonLet - '[ '( "foo" - , JsonObject + '[ "foo" := JsonObject '[ "recfoo" ::: JsonArray (JsonRef "bar") , "valfoo" ::: JsonInt ] - ) - , '( "bar" - , JsonObject + , "bar" := JsonObject '[ "recbar" ::: JsonArray (JsonRef "foo") , "valbar" ::: JsonString ] - ) ] (JsonRef "bar") )) @@ -536,14 +531,10 @@ actual = toOpenApiSchema (Proxy @(Rename ( JsonLet - '[ '("foo" - , JsonLet - '[ '( "foo" - , JsonString - ) + '[ "foo" := JsonLet + '[ "foo" := JsonString ] (JsonRef "foo") - ) ] (JsonRef "foo") ))) @@ -582,11 +573,8 @@ actual = toOpenApiSchema (Proxy @(Rename ( JsonLet - '[ '("foo" - , JsonLet - '[ '( "foo" - , JsonString - ) + '[ "foo" := JsonLet + '[ "foo" := JsonString ] ( JsonObject @@ -594,10 +582,7 @@ , ("field2" ::? JsonRef "bar") ] ) - ) - , '( "bar" - , JsonString - ) + , "bar" := JsonString ] (JsonRef "foo") ))) @@ -657,28 +642,26 @@ actual = toOpenApiSchema (Proxy @(Rename ( JsonLet - '[ '( "foo" - , JsonLet - '[ '("foo", JsonString) ] + '[ "foo" := JsonLet + '[ "foo" := JsonString ] ( JsonObject '[ "field1" ::: JsonRef "foo" , "field2" ::: JsonLet - '[ '("foo", JsonInt) ] + '[ "foo" := JsonInt ] (JsonRef "foo") , "field3" ::: JsonLet - '[ '("foo", JsonBool) ] + '[ "foo" := JsonBool ] (JsonRef "foo") ] ) - ) ] ( JsonObject '[ "field1" ::: JsonRef "foo" , "field2" ::: JsonLet - '[ '("foo", JsonNullable JsonString) ] + '[ "foo" := JsonNullable JsonString ] (JsonRef "foo") ] ) @@ -686,12 +669,67 @@ in Aeson.encode actual `shouldBe` Aeson.encode expected + it "closed module binding" $ + let + taxSchema :: OA.Schema + taxSchema = + mempty + & set OA.type_ (Just OA.OpenApiObject) + & set OA.properties ( + mempty + & set (at "rate") (Just (OA.Ref (OA.Reference "Rate"))) + ) + & set OA.required ["rate"] + & set + OA.additionalProperties + (Just (OA.AdditionalPropertiesAllowed False)) + + expected :: (Definitions OA.Schema, OA.Schema) + expected = + ( HMI.fromList + [ ("Id", stringSchema) + , ("Rate", numSchema) + , ("Tax", taxSchema) + ] + , mempty + & set OA.type_ (Just OA.OpenApiObject) + & set OA.properties ( + mempty + & set (at "id") (Just (OA.Ref (OA.Reference "Id"))) + & set (at "tax") (Just (OA.Ref (OA.Reference "Tax"))) + ) + & set OA.required ["id", "tax"] + & set + OA.additionalProperties + (Just (OA.AdditionalPropertiesAllowed False)) + ) + + actual :: (Definitions OA.Schema, OA.Schema) + actual = + toOpenApiSchema (Proxy @( + JsonLet + '[ "Id" := JsonString + , "Tax" ::= + 'Module + (JsonLet + '[ "Rate" := JsonNum ] + (JsonObject '[ "rate" ::: JsonRef "Rate" ])) + ] + (JsonObject + '[ "id" ::: JsonRef "Id" + , "tax" ::: JsonRef "Tax" + ]) + )) + in + Aeson.encode actual `shouldBe` Aeson.encode expected + describe "annotated" $ do it "JsonAnnotated wrapping object (EncodingSpec AnnotatedUser)" $ let actual :: (Definitions OA.Schema, OA.Schema) - actual = toOpenApiSchema (Proxy @(EncodingSpec AnnotatedUser)) + actual = toOpenApiSchema (Proxy @(JsonModule (EncodingSpec AnnotatedUser))) + expected :: (Definitions OA.Schema, OA.Schema) expected = ( mempty @@ -714,8 +752,9 @@ it "JsonAnnotated with empty list is no-op" $ let actual :: (Definitions OA.Schema, OA.Schema) - actual = toOpenApiSchema (Proxy @(EncodingSpec EmptyAnnotatedUser)) + actual = toOpenApiSchema (Proxy @(JsonModule (EncodingSpec EmptyAnnotatedUser))) + expected :: (Definitions OA.Schema, OA.Schema) expected = ( mempty @@ -737,8 +776,9 @@ it "JsonAnnotated with Symbol-valued \"schema-modifier\" is ignored (no-op)" $ let actual :: (Definitions OA.Schema, OA.Schema) - actual = toOpenApiSchema (Proxy @(EncodingSpec SymbolSchemaModifierUser)) + actual = toOpenApiSchema (Proxy @(JsonModule (EncodingSpec SymbolSchemaModifierUser))) + expected :: (Definitions OA.Schema, OA.Schema) expected = ( mempty @@ -760,8 +800,9 @@ it "JsonAnnotated with Type-valued list but no \"schema-modifier\" key is no-op" $ let actual :: (Definitions OA.Schema, OA.Schema) - actual = toOpenApiSchema (Proxy @(EncodingSpec OtherTypeAnnotationUser)) + actual = toOpenApiSchema (Proxy @(JsonModule (EncodingSpec OtherTypeAnnotationUser))) + expected :: (Definitions OA.Schema, OA.Schema) expected = ( mempty @@ -814,20 +855,23 @@ } deriving stock (Show, Eq) deriving ToSchema via (EncodingSchema User) -- <-- ToSchema instance defined here - deriving (ToJSON, FromJSON) via (SpecJSON User) + deriving (ToJSON, FromJSON) via (SpecJson User) instance HasJsonEncodingSpec User where type EncodingSpec User = - JsonObject - '[ Required "name" JsonString - , Optional "last-login" JsonDateTime - ] - toJSONStructure user = + 'Module + (JsonObject + '[ Required "name" JsonString + , Optional "last-login" JsonDateTime + ]) +instance TupleEncoding User where + toJsonStructure user = (Field @"name" (name user), (fmap (Field @"last-login") (lastLogin user), ())) instance HasJsonDecodingSpec User where type DecodingSpec User = EncodingSpec User - fromJSONStructure +instance TupleDecoding User where + fromJsonStructure (Field @"name" name, (fmap (unField @"last-login") -> lastLogin, ())) @@ -841,26 +885,29 @@ , auAge :: Int } deriving stock (Show, Eq) - deriving (ToJSON, FromJSON) via (SpecJSON AnnotatedUser) + deriving (ToJSON, FromJSON) via (SpecJson AnnotatedUser) instance SchemaModifier AnnotatedUser where modifySchema schema = schema & set OA.description (Just "A user with a name and age") instance HasJsonEncodingSpec AnnotatedUser where type EncodingSpec AnnotatedUser = - JsonAnnotated - '[ '("schema-modifier", AnnotatedUser) - ] - (JsonObject - '[ Required "name" JsonString - , Required "age" JsonInt - ]) - toJSONStructure AnnotatedUser { auName, auAge } = + 'Module + (JsonAnnotated + '[ '("schema-modifier", AnnotatedUser) + ] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ])) +instance TupleEncoding AnnotatedUser where + toJsonStructure AnnotatedUser { auName, auAge } = (Field @"name" auName, (Field @"age" auAge, ())) instance HasJsonDecodingSpec AnnotatedUser where type DecodingSpec AnnotatedUser = EncodingSpec AnnotatedUser - fromJSONStructure +instance TupleDecoding AnnotatedUser where + fromJsonStructure (Field @"name" auName, (Field @"age" auAge, ())) @@ -874,22 +921,25 @@ , eauAge :: Int } deriving stock (Show, Eq) - deriving (ToJSON, FromJSON) via (SpecJSON EmptyAnnotatedUser) + deriving (ToJSON, FromJSON) via (SpecJson EmptyAnnotatedUser) instance HasJsonEncodingSpec EmptyAnnotatedUser where type EncodingSpec EmptyAnnotatedUser = - JsonAnnotated - '[] - (JsonObject - '[ Required "name" JsonString - , Required "age" JsonInt - ]) - toJSONStructure EmptyAnnotatedUser { eauName, eauAge } = + 'Module + (JsonAnnotated + '[] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ])) +instance TupleEncoding EmptyAnnotatedUser where + toJsonStructure EmptyAnnotatedUser { eauName, eauAge } = (Field @"name" eauName, (Field @"age" eauAge, ())) instance HasJsonDecodingSpec EmptyAnnotatedUser where type DecodingSpec EmptyAnnotatedUser = EncodingSpec EmptyAnnotatedUser - fromJSONStructure +instance TupleDecoding EmptyAnnotatedUser where + fromJsonStructure (Field @"name" eauName, (Field @"age" eauAge, ())) @@ -903,23 +953,26 @@ , ssmAge :: Int } deriving stock (Show, Eq) - deriving (ToJSON, FromJSON) via (SpecJSON SymbolSchemaModifierUser) + deriving (ToJSON, FromJSON) via (SpecJson SymbolSchemaModifierUser) instance HasJsonEncodingSpec SymbolSchemaModifierUser where type EncodingSpec SymbolSchemaModifierUser = - JsonAnnotated - '[ '("schema-modifier", "ignored-symbol-value") - ] - (JsonObject - '[ Required "name" JsonString - , Required "age" JsonInt - ]) - toJSONStructure SymbolSchemaModifierUser { ssmName, ssmAge } = + 'Module + (JsonAnnotated + '[ '("schema-modifier", "ignored-symbol-value") + ] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ])) +instance TupleEncoding SymbolSchemaModifierUser where + toJsonStructure SymbolSchemaModifierUser { ssmName, ssmAge } = (Field @"name" ssmName, (Field @"age" ssmAge, ())) instance HasJsonDecodingSpec SymbolSchemaModifierUser where type DecodingSpec SymbolSchemaModifierUser = EncodingSpec SymbolSchemaModifierUser - fromJSONStructure +instance TupleDecoding SymbolSchemaModifierUser where + fromJsonStructure (Field @"name" ssmName, (Field @"age" ssmAge, ())) @@ -934,23 +987,26 @@ , otaAge :: Int } deriving stock (Show, Eq) - deriving (ToJSON, FromJSON) via (SpecJSON OtherTypeAnnotationUser) + deriving (ToJSON, FromJSON) via (SpecJson OtherTypeAnnotationUser) instance HasJsonEncodingSpec OtherTypeAnnotationUser where type EncodingSpec OtherTypeAnnotationUser = - JsonAnnotated - '[ '("other-key", OtherAnnotation) - ] - (JsonObject - '[ Required "name" JsonString - , Required "age" JsonInt - ]) - toJSONStructure OtherTypeAnnotationUser { otaName, otaAge } = + 'Module + (JsonAnnotated + '[ '("other-key", OtherAnnotation) + ] + (JsonObject + '[ Required "name" JsonString + , Required "age" JsonInt + ])) +instance TupleEncoding OtherTypeAnnotationUser where + toJsonStructure OtherTypeAnnotationUser { otaName, otaAge } = (Field @"name" otaName, (Field @"age" otaAge, ())) instance HasJsonDecodingSpec OtherTypeAnnotationUser where type DecodingSpec OtherTypeAnnotationUser = EncodingSpec OtherTypeAnnotationUser - fromJSONStructure +instance TupleDecoding OtherTypeAnnotationUser where + fromJsonStructure (Field @"name" otaName, (Field @"age" otaAge, ()))