json-spec-openapi 1.3.0.1 → 2.0.0.0
raw patch · 5 files changed
+326/−185 lines, 5 filesdep ~json-specPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: json-spec
API changes (from Hackage documentation)
- Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs defs more, Data.JsonSpec.OpenApi.Inlineable defs spec, GHC.Internal.TypeLits.KnownSymbol name) => Data.JsonSpec.OpenApi.Defs defs ('(name, spec) : more)
- Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs newDefs newDefs, Data.JsonSpec.OpenApi.Refable (Data.JsonSpec.OpenApi.Concat newDefs defs) spec) => Data.JsonSpec.OpenApi.Refable defs ('Data.JsonSpec.Spec.JsonLet newDefs spec)
- Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Inlineable (Data.JsonSpec.OpenApi.Concat newDefs defs) spec, Data.JsonSpec.OpenApi.Defs (Data.JsonSpec.OpenApi.Concat newDefs defs) newDefs) => Data.JsonSpec.OpenApi.Inlineable defs ('Data.JsonSpec.Spec.JsonLet newDefs spec)
- Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable (Data.JsonSpec.Decode.DecodingSpec a), GHC.Internal.Data.Typeable.Internal.Typeable a) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.DecodingSchema a)
- Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable (Data.JsonSpec.Encode.EncodingSpec a), GHC.Internal.Data.Typeable.Internal.Typeable a) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.EncodingSchema a)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs (Data.JsonSpec.OpenApi.BindingsToFrame newDefs) newDefs, Data.JsonSpec.OpenApi.Refable (Data.JsonSpec.OpenApi.Concat (Data.JsonSpec.OpenApi.BindingsToFrame newDefs) defs) spec) => Data.JsonSpec.OpenApi.Refable defs ('Data.JsonSpec.Spec.JsonLet newDefs spec)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs defs more, Data.JsonSpec.OpenApi.Inlineable '[] spec, GHC.Internal.TypeLits.KnownSymbol name) => Data.JsonSpec.OpenApi.Defs defs ('Data.JsonSpec.Spec.ModuleBind name ('Data.JsonSpec.Spec.Module spec) : more)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Defs defs more, Data.JsonSpec.OpenApi.Inlineable defs spec, GHC.Internal.TypeLits.KnownSymbol name) => Data.JsonSpec.OpenApi.Defs defs ('Data.JsonSpec.Spec.TypeBind name spec : more)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Inlineable (Data.JsonSpec.OpenApi.Concat (Data.JsonSpec.OpenApi.BindingsToFrame newDefs) defs) spec, Data.JsonSpec.OpenApi.Defs (Data.JsonSpec.OpenApi.Concat (Data.JsonSpec.OpenApi.BindingsToFrame newDefs) defs) newDefs) => Data.JsonSpec.OpenApi.Inlineable defs ('Data.JsonSpec.Spec.JsonLet newDefs spec)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonModule (Data.JsonSpec.Spec.DecodingSpec a)), GHC.Internal.Data.Typeable.Internal.Typeable a) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.DecodingSchema a)
+ Data.JsonSpec.OpenApi: instance (Data.JsonSpec.OpenApi.Schemaable ('Data.JsonSpec.Spec.JsonModule (Data.JsonSpec.Spec.EncodingSpec a)), GHC.Internal.Data.Typeable.Internal.Typeable a) => Data.OpenApi.Internal.Schema.ToSchema (Data.JsonSpec.OpenApi.EncodingSchema a)
+ Data.JsonSpec.OpenApi: instance Data.JsonSpec.OpenApi.Inlineable '[] spec => Data.JsonSpec.OpenApi.Inlineable defs ('Data.JsonSpec.Spec.JsonModule ('Data.JsonSpec.Spec.Module spec))
Files
- CHANGELOG.md +7/−0
- json-spec-openapi.cabal +7/−10
- src/Data/JsonSpec/OpenApi.hs +73/−49
- src/Data/JsonSpec/OpenApi/Rename.hs +89/−32
- test/test.hs +150/−94
CHANGELOG.md view
@@ -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.
json-spec-openapi.cabal view
@@ -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
src/Data/JsonSpec/OpenApi.hs view
@@ -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\") -}
src/Data/JsonSpec/OpenApi/Rename.hs view
@@ -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
test/test.hs view
@@ -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, ()))