json-spec-openapi 1.1.0.0 → 1.2.0.1

raw patch · 6 files changed

+328/−81 lines, 6 filesdep ~basedep ~json-specPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, json-spec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• LICENSE +1/−1
• json-spec-openapi.cabal +6/−5
• src/Data/JsonSpec/OpenApi.hs +112/−34
• src/Data/JsonSpec/OpenApi/Rename.hs +29/−31
• test/test.hs +171/−10

@@ -0,0 +1,9 @@+# Changelog++All notable changes to this project will be documented in this file.++## Unreleased++- Upgraded the json-spec dependency (adapts to json-spec 1.3 breaking change+  where `JsonEither` takes a type-level list of specs instead of two+  arguments).

@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2023 Rick Owens+Copyright (c) 2026 Rick Owens  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                json-spec-openapi-version:             1.1.0.0+version:             1.2.0.1 synopsis:            json-spec-openapi description:   This package provides a way to produce@@ -52,19 +52,20 @@ license-file:        LICENSE author:              Rick Owens maintainer:          rick@owensmurray.com-copyright:           2025 Owens Murray, LLC.+copyright:           2026 Owens Murray, LLC. category:            JSON, OpenApi build-type:          Simple-extra-source-files:+extra-doc-files:   README.md   LICENSE+  CHANGELOG.md  common dependencies   build-depends:     , aeson                     >= 2.2.1.0  && < 2.3-    , base                      >= 4.19.0.0 && < 4.22+    , base                      >= 4.19.2.0 && < 4.22     , insert-ordered-containers >= 0.2.5.3  && < 0.3-    , json-spec                 >= 1.2.0.0  && < 1.3+    , json-spec                 >= 1.3.0.0  && < 1.4     , lens                      >= 5.2.3    && < 5.4     , openapi3                  >= 3.2.4    && < 3.3     , text                      >= 2.1      && < 2.2

@@ -91,6 +91,36 @@   >                   (Just (AdditionalPropertiesAllowed True))   >           ) +  === Annotations and schema modification++  You can wrap a specification in 'JsonAnnotated' to attach+  type-level annotations. This library interprets one annotation:+  @\"schema-modifier\"@ with a value of kind 'Type'. Use it to+  customize the generated schema (e.g. set description, readOnly, or+  other OpenAPI fields) by giving that type a 'SchemaModifier'+  instance. While you may use any type that has an instance, using the+  base type for which you are specifying an encoding may be the most+  convenient.++  Other annotation kinds (e.g. @[(Symbol, Symbol)]@ for description+  strings) and other keys are no-op here so that other tools can+  interpret them without causing compile errors.++  Example (you may need @-XFlexibleInstances@ for the instance):++  > data AnnotatedUser = AnnotatedUser { name_ :: Text, age_ :: Int }+  >   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, ()))++  The type in @\"schema-modifier\"@ must have a 'SchemaModifier'+  instance or you get a type error; it is not ignored.+ -} module Data.JsonSpec.OpenApi (   toOpenApiSchema,@@ -98,6 +128,7 @@   EncodingSchema(..),   DecodingSchema(..),   Rename,+  SchemaModifier(..), ) where  @@ -116,7 +147,7 @@ import Data.JsonSpec.OpenApi.Rename (Rename) import Data.OpenApi   ( AdditionalProperties(AdditionalPropertiesAllowed)-  , HasAdditionalProperties(additionalProperties), HasDescription(description)+  , HasAdditionalProperties(additionalProperties)   , HasEnum(enum_), HasFormat(format), HasItems(items), HasOneOf(oneOf)   , HasProperties(properties), HasRequired(required), HasType(type_)   , NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject)@@ -130,12 +161,13 @@ import Data.OpenApi.Declare (DeclareT(runDeclareT), MonadDeclare(declare)) import Data.String (IsString(fromString)) import Data.Text (Text)+import Data.Kind (Type) import Data.Typeable (Proxy(Proxy), Typeable) import GHC.TypeError (ErrorMessage((:$$:), (:<>:)), Unsatisfiable, unsatisfiable) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Prelude-  ( Applicative(pure), Bool(False), Functor(fmap), Maybe(Just, Nothing)-  , Monoid(mempty), ($), (.), id+  ( Applicative(pure, (<*>)), Bool(False), Functor(fmap), Maybe(Just, Nothing)+  , Monoid(mempty), ($), (.), (<$>), id   ) import qualified Data.HashMap.Strict.InsOrd as HMI import qualified Data.OpenApi as OA@@ -246,23 +278,16 @@   inlineable =     pure $       mempty & set type_ (Just OpenApiString)-instance {- Inlineable defs ('JsonEither left right) -}-    ( Refable defs left-    , Refable defs right-    )+instance {- Inlineable defs ('JsonEither specs) -}+    (RefableList defs specs)   =>-    Inlineable defs ('JsonEither left right)+    Inlineable defs (JsonEither specs)   where     inlineable = do-      schemaLeft <- refable @defs @left-      schemaRight <- refable @defs @right+      schemaList <- refableList @defs @specs       pure $         mempty-          & set oneOf (Just-              [ schemaLeft-              , schemaRight-              ]-          )+          & set oneOf (Just schemaList) instance Inlineable defs JsonNum where   inlineable =     pure $@@ -367,10 +392,35 @@   where     inlineable = do       schema <- inlineable @defs @spec-      pure (applyAnnotations @annotations schema)+      pure (applyAnnotations (Proxy @annotations) schema)   {-|+  Like 'Refable' but for a type-level list of specifications; produces+  a list of schemas (used for 'JsonEither' oneOf).+-}+class+    RefableList+      (defs :: [(Symbol, Specification)])+      (specs :: [Specification])+  where+    refableList+      :: (MonadDeclare (Definitions Schema) m)+      => m [Referenced Schema]+instance RefableList defs '[] where+  refableList = pure []+instance+    ( Refable defs spec+    , RefableList defs more+    )+  =>+    RefableList defs (spec ': more)+  where+    refableList =+      (:) <$> refable @defs @spec <*> refableList @defs @more+++{-|   Specifications that can be turned into OpenApi Schemas or a reference   to a schema. -}@@ -538,13 +588,15 @@  {-|   Look up a key in a list of annotation pairs. Returns 'Just value if found,-  'Nothing otherwise.+  'Nothing otherwise. The annotations list is poly-kinded in the value type+  so that different tools can use different kinds (e.g. this library looks up+  \"schema-modifier\" for a value of kind 'Type' to apply 'SchemaModifier'). -} type family     LookupAnnotation       (key :: Symbol)-      (annotations :: [(Symbol, Symbol)])-      :: Maybe Symbol+      (annotations :: [(Symbol, k)])+      :: Maybe k   where     LookupAnnotation key '[] = 'Nothing     LookupAnnotation key ( '(key, value) ': more ) = 'Just value@@ -552,28 +604,54 @@   {-|-  Apply annotations to a schema. Currently only "description" is supported;-  all other annotations are ignored.+  Apply annotations to a schema. We only interpret @[(Symbol, Type)]@+  (for the \"schema-modifier\" hook); all other annotation kinds are+  no-op here so that json-spec users can use other kinds (e.g. 'Symbol',+  'Bool', 'Nat', or custom kinds) for other tools without causing+  compile errors in this library. -}-class ApplyAnnotations (annotations :: [(Symbol, Symbol)]) where-  applyAnnotations :: Schema -> Schema+class ApplyAnnotations (annotations :: [(Symbol, k)]) where+  applyAnnotations :: Proxy annotations -> Schema -> Schema+instance {-# OVERLAPPABLE #-} ApplyAnnotations (annotations :: [(Symbol, k)]) where+  applyAnnotations _proxy = id instance-    (ApplyDescription (LookupAnnotation "description" annotations))+    (ApplySchemaModifier (LookupAnnotation "schema-modifier" annotations))   =>-    ApplyAnnotations annotations+    ApplyAnnotations (annotations :: [(Symbol, Type)])   where-    applyAnnotations = applyDescription @(LookupAnnotation "description" annotations)+    applyAnnotations _proxy = applySchemaModifier @(LookupAnnotation "schema-modifier" annotations)   {-|-  Helper class for applying a description annotation to a schema.+  User-defined schema modifier. Use this to customize how a schema is+  transformed when the \"schema-modifier\" annotation appears in a+  'JsonAnnotated' list with a value of your type.++  While you may use any type that has an instance, using the base type+  for which you are specifying an encoding may be the most convenient. If you+  use a type that has no 'SchemaModifier' instance, you get a type+  error (it is not ignored).++  Example (you may need @-XFlexibleInstances@ for the instance):++  > type EncodingSpec AnnotatedUser =+  >   JsonAnnotated '[ '(\"schema-modifier\", AnnotatedUser) ]+  >     (JsonObject ...)+  > instance SchemaModifier AnnotatedUser where+  >   modifySchema schema = schema & set description (Just \"A user\") -}-class ApplyDescription (desc :: Maybe Symbol) where-  applyDescription :: Schema -> Schema-instance ApplyDescription 'Nothing where-  applyDescription = id-instance (KnownSymbol desc) => ApplyDescription ('Just desc) where-  applyDescription schema =-    schema & set description (Just (sym @desc))+class SchemaModifier (t :: Type) where+  modifySchema :: Schema -> Schema+++{-|+  Apply a schema modifier when present in the annotation lookup result.+-}+class ApplySchemaModifier (m :: Maybe Type) where+  applySchemaModifier :: Schema -> Schema+instance ApplySchemaModifier 'Nothing where+  applySchemaModifier = id+instance (SchemaModifier t) => ApplySchemaModifier ('Just t) where+  applySchemaModifier = modifySchema @t  

@@ -73,6 +73,22 @@   type family+    Snd+      (a :: (Specification, Global))+      :: Global+  where+    Snd '(spec, global) = global+++type family+    GetEitherList+      (spec :: Specification)+      :: [Specification]+  where+    GetEitherList (JsonEither specs) = specs+++type family     FoldRename       (global :: Global)       (active :: Active)@@ -104,8 +120,8 @@     FoldRename global active (JsonObject fields) =       RenameObject global active fields -    FoldRename global active (JsonEither left right) =-      RenameEither global active left right+    FoldRename global active (JsonEither specs) =+      RenameEitherList global active specs      FoldRename global active (JsonLet defs spec) =       RenameLet@@ -208,39 +224,21 @@   type family-    RenameEither+    RenameEitherList       (global :: Global)       (active :: Active)-      (  left :: Specification)-      ( right :: Specification)-      :: (Specification, Global)-  where-    RenameEither global active left right =-      RenameEither2-        active-        (FoldRename global active left)-        right---type family-    RenameEither2-      (active :: Active)-      (  left :: (Specification, Global))-      ( right :: Specification)-      :: (Specification, Global)-  where-    RenameEither2 active '(left, global) right =-      RenameEither3 left (FoldRename global active right)---type family-    RenameEither3-      (left :: Specification)-      (right :: (Specification, Global))+      (specs :: [Specification])       :: (Specification, Global)   where-    RenameEither3 left '(right, global) =-      '(JsonEither left right, global)+    RenameEitherList global active '[spec] =+      '(JsonEither '[Fst (FoldRename global active spec)], Snd (FoldRename global active spec))+    RenameEitherList global active (spec ': more) =+      '( JsonEither+           (Fst (FoldRename global active spec)+             ': GetEitherList+                  (Fst (RenameEitherList (Snd (FoldRename global active spec)) active more)))+       , Snd (RenameEitherList (Snd (FoldRename global active spec)) active more)+       )   type family

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -26,7 +27,9 @@     )   , (:::), (::?), unField   )-import Data.JsonSpec.OpenApi (EncodingSchema, Rename, toOpenApiSchema)+import Data.JsonSpec.OpenApi+  ( EncodingSchema, Rename, SchemaModifier(modifySchema), toOpenApiSchema+  ) import Data.OpenApi (Definitions, ToSchema) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text)@@ -61,18 +64,15 @@           actual =             toOpenApiSchema (Proxy @(               JsonEither-                (-                  JsonObject+                '[ JsonObject                     '[ Required "tag" (JsonTag "a")                      , Required "content" JsonString                      ]-                )-                (-                  JsonObject+                , JsonObject                     '[ Required "tag" (JsonTag "b")                      , Required "content" JsonString                      ]-                )+                ]             ))            expected :: (Definitions OA.Schema, OA.Schema)@@ -692,6 +692,75 @@         in           actual `shouldBe` expected +      it "JsonAnnotated with empty list is no-op" $+        let+          actual :: (Definitions OA.Schema, OA.Schema)+          actual = toOpenApiSchema (Proxy @(EncodingSpec EmptyAnnotatedUser))++          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( mempty+            , mempty+                & set OA.type_ (Just OA.OpenApiObject)+                & set OA.properties (+                    mempty+                      & set (at "name") (Just (OA.Inline stringSchema))+                      & set (at "age") (Just (OA.Inline intSchema))+                  )+                & set OA.required ["name", "age"]+                & set+                    OA.additionalProperties+                    (Just (OA.AdditionalPropertiesAllowed False))+            )+        in+          actual `shouldBe` expected++      it "JsonAnnotated with Symbol-valued \"schema-modifier\" is ignored (no-op)" $+        let+          actual :: (Definitions OA.Schema, OA.Schema)+          actual = toOpenApiSchema (Proxy @(EncodingSpec SymbolSchemaModifierUser))++          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( mempty+            , mempty+                & set OA.type_ (Just OA.OpenApiObject)+                & set OA.properties (+                    mempty+                      & set (at "name") (Just (OA.Inline stringSchema))+                      & set (at "age") (Just (OA.Inline intSchema))+                  )+                & set OA.required ["name", "age"]+                & set+                    OA.additionalProperties+                    (Just (OA.AdditionalPropertiesAllowed False))+            )+        in+          actual `shouldBe` expected++      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))++          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( mempty+            , mempty+                & set OA.type_ (Just OA.OpenApiObject)+                & set OA.properties (+                    mempty+                      & set (at "name") (Just (OA.Inline stringSchema))+                      & set (at "age") (Just (OA.Inline intSchema))+                  )+                & set OA.required ["name", "age"]+                & set+                    OA.additionalProperties+                    (Just (OA.AdditionalPropertiesAllowed False))+            )+        in+          actual `shouldBe` expected+     describe "EncodingSchema" $       it "works" $         let@@ -747,18 +816,20 @@       pure User { name , lastLogin }  -{- Annotated test: EncodingSpec uses JsonAnnotated. -}+{- Annotated test: EncodingSpec uses JsonAnnotated and SchemaModifier. -} data AnnotatedUser = AnnotatedUser   { auName :: Text   ,  auAge :: Int   }   deriving stock (Show, Eq)   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-      '[ '("description", "A user with a name and age")-       , '("example", "{\"name\": \"alice\", \"age\": 30}")+      '[ '("schema-modifier", AnnotatedUser)        ]       (JsonObject         '[ Required "name" JsonString@@ -776,6 +847,96 @@       ()))     =       pure AnnotatedUser { auName, auAge }+++{- Empty annotations: catch-all applies, no-op. -}+data EmptyAnnotatedUser = EmptyAnnotatedUser+  { eauName :: Text+  ,  eauAge :: Int+  }+  deriving stock (Show, Eq)+  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 } =+    (Field @"name" eauName,+    (Field @"age" eauAge,+    ()))+instance HasJsonDecodingSpec EmptyAnnotatedUser where+  type DecodingSpec EmptyAnnotatedUser = EncodingSpec EmptyAnnotatedUser+  fromJSONStructure+      (Field @"name" eauName,+      (Field @"age" eauAge,+      ()))+    =+      pure EmptyAnnotatedUser { eauName, eauAge }+++{- Symbol-valued "schema-modifier" key: kind is [(Symbol, Symbol)], no-op. -}+data SymbolSchemaModifierUser = SymbolSchemaModifierUser+  { ssmName :: Text+  ,  ssmAge :: Int+  }+  deriving stock (Show, Eq)+  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 } =+    (Field @"name" ssmName,+    (Field @"age" ssmAge,+    ()))+instance HasJsonDecodingSpec SymbolSchemaModifierUser where+  type DecodingSpec SymbolSchemaModifierUser = EncodingSpec SymbolSchemaModifierUser+  fromJSONStructure+      (Field @"name" ssmName,+      (Field @"age" ssmAge,+      ()))+    =+      pure SymbolSchemaModifierUser { ssmName, ssmAge }+++{- Type-valued annotations but key is not "schema-modifier": no-op. -}+data OtherAnnotation+data OtherTypeAnnotationUser = OtherTypeAnnotationUser+  { otaName :: Text+  ,  otaAge :: Int+  }+  deriving stock (Show, Eq)+  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 } =+    (Field @"name" otaName,+    (Field @"age" otaAge,+    ()))+instance HasJsonDecodingSpec OtherTypeAnnotationUser where+  type DecodingSpec OtherTypeAnnotationUser = EncodingSpec OtherTypeAnnotationUser+  fromJSONStructure+      (Field @"name" otaName,+      (Field @"age" otaAge,+      ()))+    =+      pure OtherTypeAnnotationUser { otaName, otaAge }   stringSchema :: OA.Schema