json-spec-openapi 0.3.1.2 → 1.0.0.0

raw patch · 4 files changed

+1116/−180 lines, 4 filesdep ~json-specPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: json-spec

API changes (from Hackage documentation)

Files

• json-spec-openapi.cabal +4/−3
• src/Data/JsonSpec/OpenApi.hs +205/−162
• src/Data/JsonSpec/OpenApi/Rename.hs +611/−0
• test/test.hs +296/−15

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                json-spec-openapi-version:             0.3.1.2+version:             1.0.0.0 synopsis:            json-spec-openapi description:   This package provides a way to produce@@ -64,7 +64,7 @@     , aeson                     >= 2.2.1.0  && < 2.3     , base                      >= 4.19.0.0 && < 4.21     , insert-ordered-containers >= 0.2.5.3  && < 0.3-    , json-spec                 >= 0.5.0.0  && < 1.1+    , json-spec                 >= 0.5.0.0  && < 1.2     , lens                      >= 5.2.3    && < 5.4     , openapi3                  >= 3.2.4    && < 3.3     , text                      >= 2.1      && < 2.2@@ -82,7 +82,8 @@   import: dependencies, warnings   exposed-modules:          Data.JsonSpec.OpenApi-  -- other-modules:       +  other-modules:       +    Data.JsonSpec.OpenApi.Rename   -- other-extensions:       hs-source-dirs:      src   default-language:    Haskell2010

@@ -1,9 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -95,36 +97,47 @@   Schemaable,   EncodingSchema(..),   DecodingSchema(..),+  Rename, ) where   import Control.Lens (At(at), (&), over, set) import Data.Aeson (ToJSON(toJSON)) import Data.Functor.Identity (Identity(runIdentity))-import Data.JsonSpec (FieldSpec(Optional, Required),-  HasJsonDecodingSpec(DecodingSpec), HasJsonEncodingSpec(EncodingSpec),-  Specification(JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt,-  JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef,-  JsonString, JsonTag))-import Data.OpenApi (AdditionalProperties(AdditionalPropertiesAllowed),-  HasAdditionalProperties(additionalProperties), HasEnum(enum_),-  HasFormat(format), HasItems(items), HasOneOf(oneOf),-  HasProperties(properties), HasRequired(required), HasType(type_),-  NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject),-  OpenApiType(OpenApiArray, OpenApiBoolean, OpenApiInteger, OpenApiNull,-  OpenApiNumber, OpenApiObject, OpenApiString), Reference(Reference),-  Referenced(Inline, Ref), ToSchema(declareNamedSchema), Definitions,-  Schema)+import Data.JsonSpec+  ( FieldSpec(Optional, Required), HasJsonDecodingSpec(DecodingSpec)+  , HasJsonEncodingSpec(EncodingSpec)+  , Specification+    ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet+    , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag+    )+  )+import Data.JsonSpec.OpenApi.Rename (Rename)+import Data.OpenApi+  ( AdditionalProperties(AdditionalPropertiesAllowed)+  , HasAdditionalProperties(additionalProperties), HasEnum(enum_)+  , HasFormat(format), HasItems(items), HasOneOf(oneOf)+  , HasProperties(properties), HasRequired(required), HasType(type_)+  , NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject)+  , OpenApiType+    ( OpenApiArray, OpenApiBoolean, OpenApiInteger, OpenApiNull, OpenApiNumber+    , OpenApiObject, OpenApiString+    )+  , Reference(Reference), Referenced(Inline), ToSchema(declareNamedSchema)+  , Definitions, Schema+  ) import Data.OpenApi.Declare (DeclareT(runDeclareT), MonadDeclare(declare)) import Data.String (IsString(fromString)) import Data.Text (Text) import Data.Typeable (Proxy(Proxy), Typeable)-import GHC.TypeError (ErrorMessage((:$$:), (:<>:)), Unsatisfiable,-  unsatisfiable)+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), ($), (.))+import Prelude+  ( Applicative(pure), Bool(False), Functor(fmap), Maybe(Just, Nothing)+  , Monoid(mempty), ($), (.)+  ) import qualified Data.HashMap.Strict.InsOrd as HMI+import qualified Data.OpenApi as OA import qualified GHC.TypeError as TE  @@ -192,37 +205,12 @@       been defined. -} toOpenApiSchema-  :: (Schemaable spec)+  :: forall spec.+     (Schemaable spec)   => Proxy (spec :: Specification)   -> (Definitions Schema, Schema)-toOpenApiSchema spec =-  runIdentity (runDeclareT (schemaable spec) mempty)---{-|-  Specifications that can be turned into OpenApi Schemas or a reference-  to a schema.--}-class Refable (spec :: Specification) where-  refable-    :: (MonadDeclare (Definitions Schema) m)-    => Proxy spec-    -> m (Referenced Schema)-instance (KnownSymbol name) => Refable (JsonRef name) where-  refable Proxy =-    pure (ref (sym @name))-instance-    ( Defs defs-    , KnownSymbol name-    )-  =>-    Refable (JsonLet defs (JsonRef name))-  where-    refable Proxy = do-      mkDefs (Proxy @defs)-      refable (Proxy @(JsonRef name))-instance {-# overlaps #-} (Schemaable a) => Refable a where-  refable = fmap Inline . schemaable+toOpenApiSchema Proxy =+  runIdentity (runDeclareT (schemaable @spec) mempty)   {-|@@ -236,180 +224,229 @@ class Schemaable (spec :: Specification) where   schemaable     :: (MonadDeclare (Definitions Schema) m)-    => Proxy spec-    -> m Schema-instance (KnownSymbol tag) => Schemaable ('JsonTag tag) where-  schemaable Proxy =+    => m Schema++instance (Inlineable '[] spec) => Schemaable spec where+  schemaable = inlineable @'[] @spec++class+    Inlineable+      (defs :: [ (Symbol, Specification) ])+      (spec :: Specification)+  where+    inlineable+      :: (MonadDeclare (Definitions Schema) m)+      => m Schema+instance (KnownSymbol tag) => Inlineable defs ('JsonTag tag) where+  inlineable =     pure $       mempty & set enum_ (Just [toJSON (sym @tag :: Text)])-instance Schemaable 'JsonString where-  schemaable Proxy =+instance Inlineable defs JsonString where+  inlineable =     pure $       mempty & set type_ (Just OpenApiString)-instance {- Schemaable ('JsonEither left right) -}-    ( Schemaable left-    , Schemaable right+instance {- Inlineable defs ('JsonEither left right) -}+    ( Refable defs left+    , Refable defs right     )   =>-    Schemaable ('JsonEither left right)+    Inlineable defs ('JsonEither left right)   where-    schemaable Proxy = do-      schemaLeft <- schemaable (Proxy @left)-      schemaRight <- schemaable (Proxy @right)+    inlineable = do+      schemaLeft <- refable @defs @left+      schemaRight <- refable @defs @right       pure $         mempty           & set oneOf (Just-              [ Inline schemaLeft-              , Inline schemaRight+              [ schemaLeft+              , schemaRight               ]           )-instance Schemaable 'JsonNum where-  schemaable Proxy =+instance Inlineable defs JsonNum where+  inlineable =     pure $       mempty & set type_ (Just OpenApiNumber)-instance Schemaable 'JsonInt where-  schemaable Proxy =+instance Inlineable defs JsonInt where+  inlineable =     pure $       mempty & set type_ (Just OpenApiInteger)-instance Schemaable ('JsonObject '[]) where-  schemaable Proxy =+instance Inlineable defs (JsonObject '[]) where+  inlineable =     pure $       mempty         & set type_ (Just OpenApiObject)         & set additionalProperties (Just (AdditionalPropertiesAllowed False))-instance {- Schemaable ('JsonObject ( Optional key spec : more )) -}-    ( Schemaable ('JsonObject more)-    , Refable spec+instance {- Inlineable defs (JsonObject ( Optional key spec : more )) -}+    ( Inlineable defs (JsonObject more)+    , Refable defs spec     , KnownSymbol key     )   =>-    Schemaable ('JsonObject ( Optional key spec : more ))+    Inlineable defs (JsonObject ( Optional key spec : more ))   where-    schemaable Proxy = do-      propertySchema <- refable (Proxy @spec)-      more <- schemaable (Proxy @('JsonObject more))+    inlineable = do+      propertySchema <- refable @defs @spec+      more <- inlineable @defs @('JsonObject more)       pure $         more           & over               properties               (set (at (sym @key)) (Just propertySchema))-instance {- Schemaable ('JsonObject ( Required key spec : more )) -}-    ( Schemaable ('JsonObject more)-    , Refable spec+instance {- Inlineable defs (JsonObject ( Required key spec : more )) -}+    ( Inlineable defs (JsonObject ( Optional key spec : more ))     , KnownSymbol key     )   =>-    Schemaable (JsonObject ( Required key spec : more ))+    Inlineable defs (JsonObject ( Required key spec : more ))   where-    schemaable Proxy = do-      schema <- schemaable (Proxy @(JsonObject ( Optional key spec : more )))+    inlineable = do+      schema <- inlineable @defs @(JsonObject ( Optional key spec : more ))       pure $         schema           & over required (sym @key:)-instance (Schemaable spec) => Schemaable ('JsonArray spec) where-  schemaable Proxy = do-    elementSchema <- schemaable (Proxy @spec)-    pure $-      mempty-        & set type_ (Just OpenApiArray)-        & set items (Just (OpenApiItemsObject (Inline elementSchema)))-instance Schemaable 'JsonBool where-  schemaable Proxy =+instance {- Inlineable defs (JsonArray spec) -}+    (Refable defs spec)+  =>+    Inlineable defs (JsonArray spec)+  where+    inlineable = do+      elementSchema <- refable @defs @spec+      pure $+        mempty+          & set type_ (Just OpenApiArray)+          & set items (Just (OpenApiItemsObject elementSchema))+instance Inlineable defs JsonBool where+  inlineable =     pure $       mempty & set type_ (Just OpenApiBoolean)-instance Schemaable 'JsonDateTime where-  schemaable Proxy =+instance Inlineable defs JsonDateTime where+  inlineable =     pure $       mempty         & set type_ (Just OpenApiString)         & set format (Just "date-time")-instance {- Undefined Let -}-    Unsatisfiable (-      T "`JsonRef \"" :<>: T target :<>: T "\"` is not defined.\n"-      :$$: T "You are trying to use a JsonRef as the \"top level\" "-      :$$: T "schema. We try to satisfy this request by looking up "-      :$$: T "the reference and inlining it.  However in this case you "-      :$$: T "are trying to reference a schema which is not defined, "-      :$$: T "so this won't work.\n"+instance (Refable defs spec) => Inlineable defs (JsonNullable spec) where+  inlineable = do+    schema <- refable @defs @spec+    pure $+      mempty+        & set oneOf (Just+            [ Inline (mempty & set type_ (Just OpenApiNull))+            , schema+            ]+        )+instance Inlineable defs JsonRaw where+  inlineable =+    pure $+      mempty+      & set type_ (Just OpenApiObject)+instance {- Inlineable defs (JsonLet newDefs spec) -}+    ( Inlineable (Concat newDefs defs) spec+    , Defs newDefs newDefs     )   =>-    Schemaable (JsonLet '[] (JsonRef target))+    Inlineable defs (JsonLet newDefs spec)   where-    schemaable = unsatisfiable-instance {- Schemaable (JsonLet ( '(target, def) ': more) (JsonRef target)) -}-    {-# overlaps #-}-    ( KnownSymbol target-    , Schemaable def-    , Schemaable (JsonLet more def)+    inlineable = do+      mkDefs @newDefs @newDefs+      inlineable @(Concat newDefs defs) @spec+instance {- Inlineable defs (JsonRef target) -}+    ( Deref defs defs target     )   =>-    Schemaable (JsonLet ( '(target, def) ': more) (JsonRef target))+    Inlineable defs (JsonRef target)   where-    schemaable Proxy = do-      defSchema <- schemaable (Proxy @def)-      declare (HMI.singleton (sym @target) defSchema)-      schemaable (Proxy @(JsonLet more def))-instance {- Schemaable (JsonLet ( '(name, def) ': more) (JsonRef target)) -}-    {-# overlaps #-}-    ( KnownSymbol name-    , Schemaable def-    , Schemaable (JsonLet more (JsonRef target))+    inlineable = deref @defs @defs @target+++{-|+  Specifications that can be turned into OpenApi Schemas or a reference+  to a schema.+-}+class+    Refable+      (defs :: [(Symbol, Specification)])+      (spec :: Specification)+  where+    refable+      :: (MonadDeclare (Definitions Schema) m)+      => m (Referenced Schema)+instance {-# overlappable #-} (Inlineable defs a) => Refable defs a where+  refable = fmap Inline (inlineable @defs @a)+instance+    ( Defs newDefs newDefs+    , Refable (Concat newDefs defs) spec     )   =>-    Schemaable (JsonLet ( '(name, def) ': more) (JsonRef target))+    Refable defs (JsonLet newDefs spec)   where-    schemaable Proxy = do-      defSchema <- schemaable (Proxy @def)-      declare (HMI.singleton (sym @name) defSchema)-      schemaable (Proxy @(JsonLet more (JsonRef target)))-instance {- Schemaable (JsonLet defs spec) -}-    {-# overlaps #-}-    ( Defs defs-    , Schemaable spec+    refable = do+      mkDefs @newDefs @newDefs+      refable @(Concat newDefs defs) @spec+instance (KnownSymbol name) => Refable defs (JsonRef name) where+  refable =+    pure (ref (sym @name))+++class+    Deref+      (defs   :: [(Symbol, Specification)])+      (search :: [(Symbol, Specification)])+      (target :: Symbol)+  where+    deref+      :: MonadDeclare (Definitions Schema) m+      => m Schema+instance (NotDereferenceable defs target) => Deref defs '[] target where+  deref = unsatisfiable+instance {- Deref defs ( '(target, spec) ': more) target -}+    ( Inlineable defs spec     )   =>-    Schemaable (JsonLet defs spec)+    Deref defs ( '(target, spec) ': more) target   where-    schemaable Proxy = do-      mkDefs (Proxy @defs)-      schemaable (Proxy @spec)-instance (Schemaable spec) => Schemaable (JsonNullable spec) where-  schemaable Proxy = do-    schema <- schemaable (Proxy @spec)-    pure $-      mempty-        & set oneOf (Just-            [ Inline (mempty & set type_ (Just OpenApiNull))-            , Inline schema-            ]-        )-instance Schemaable JsonRaw where-  schemaable Proxy =-    pure $-      mempty-      & set type_ (Just OpenApiObject)+    deref = inlineable @defs @spec+instance {- Deref defs ( '(miss, spec) ': more) target -}+    {-# overlaps #-}+    (Deref defs more target)+  =>+    Deref defs ( '(miss, spec) ': more) target+  where+    deref =+      deref @defs @more @target+type NotDereferenceable defs target =+  Unsatisfiable (+    TE.Text+      "Symbol not defined (in a position \+      \where we must dereference the referenced schema)."+      :$$: TE.Text "The symbol is: " :<>: TE.ShowType target+      :$$: TE.Text "The definitions in scope are: " :<>: TE.ShowType defs+  )   {-| Go through and make a declaration for each item in a JsonLet.  -}-class Defs (defs :: [(Symbol, Specification)]) where-  mkDefs-    :: (MonadDeclare (Definitions Schema) m)-    => Proxy defs-    -> m ()-instance Defs '[] where-  mkDefs Proxy = pure ()-instance-    ( Defs more-    , Schemaable spec+class+    Defs+      (allDefs :: [(Symbol, Specification)])+      (defs :: [(Symbol, Specification)])+  where+    mkDefs+      :: (MonadDeclare (Definitions Schema) m)+      => m ()+instance Defs defs '[] where+  mkDefs = pure ()+instance {- Defs defs ( '(name, spec) ': more) -}+    ( Defs defs more+    , Inlineable defs spec     , KnownSymbol name     )   =>-    Defs ( '(name, spec) ': more)+    Defs defs ( '(name, spec) ': more)   where-    mkDefs Proxy = do-      schema <- schemaable (Proxy @spec)+    mkDefs = do+      schema <- inlineable @defs @spec       declare (HMI.singleton (sym @name) schema)-      mkDefs (Proxy @more)+      mkDefs @defs @more   {-|@@ -475,10 +512,16 @@   ref :: Text -> Referenced a-ref = Ref . Reference+ref = OA.Ref . Reference  -{-| Shorthand for building custom type errors.  -}-type T (msg :: Symbol) = TE.Text msg+type family+    Concat+      (a :: [(Symbol, Specification)])+      (b :: [(Symbol, Specification)])+      :: [(Symbol, Specification)]+  where+    Concat '[] b = b+    Concat (a : more) b = a : Concat more b  

@@ -0,0 +1,611 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.JsonSpec.OpenApi.Rename (+  Rename+) where++import Data.JsonSpec+  ( FieldSpec(Optional, Required)+  , Specification+    ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet+    , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag+    )+  )+import GHC.TypeError (ErrorMessage((:$$:)))+import GHC.TypeLits (type (+), AppendSymbol, Nat, Symbol)+import qualified GHC.TypeError as TE+++{-|+  Resolve OpenApi name conflicts.++  The json-spec mechanism for giving names to things is more powerful than+  OpenApi mechanism for naming things. 'JsonLet' allows for nested scopes,+  where deeper names can shadow other names. OpenApi on the other hand only has+  a flat space to name schemas, so every name is "globally scoped", resulting+  in possible name conflicts when mapping 'JsonLet' names to OpenApi names.++  This type family resolves the conflict by renaming the 'JsonLet' names+  in your 'Specification' so that they are all unique, so they won't+  conflict when mapping them into the global OpenApi schema namespace.++  We do not apply this type family by default because it has the potential to+  add significant compilation time if your 'Specification's are large. If you+  happen to know that your 'Specification' contains no name conflicts then you+  can avoid paying that cost.++  It isn't perfect. I've tried to strike a balance between implementation+  complexity and avoiding unnecessary renames.++  Essentially, if a duplicate name is detected, I append a @".<n>"@ to the+  name, where @<n>@ is an integer. So if you are using names that /already/+  follow this format you might get into trouble.++  For instance, this 'Specification' will fail to rename properly:+  > JsonLet+  >   '[ '("foo", JsonString)+  >    , '("foo.1", JsonString)+  >    ]+  >    ( JsonObject+  >        '[ "field1" ::: 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".+-}+type family Rename (spec :: Specification) :: Specification where+  Rename spec =+    Fst (FoldRename (G '[]) (A '[]) spec)+++type family+    Fst+      (a :: (Specification, Global))+      :: Specification+  where+    Fst '(spec, global) = spec+++type family+    FoldRename+      (global :: Global)+      (active :: Active)+      (spec   :: Specification)+      :: (Specification, Global)+  where+    FoldRename global active JsonString = '(JsonString, global)++    FoldRename global active JsonNum = '(JsonNum, global)++    FoldRename global active JsonInt = '(JsonInt, global)++    FoldRename global active JsonBool = '(JsonBool, global)++    FoldRename global active (JsonTag tag) = '(JsonTag tag, global)++    FoldRename global active JsonDateTime = '(JsonDateTime, global)++    FoldRename global active JsonRaw = '(JsonRaw, global)++    FoldRename global active (JsonNullable spec) =+      MapSpec+        JsonNullable+        (FoldRename global active spec)++    FoldRename global active (JsonArray spec) =+      MapSpec JsonArray (FoldRename global active spec)++    FoldRename global active (JsonObject fields) =+      RenameObject global active fields++    FoldRename global active (JsonEither left right) =+      RenameEither global active left right++    FoldRename global active (JsonLet defs spec) =+      RenameLet+        (UpdateGlobals global defs)+        active+        defs+        spec++    FoldRename global (A active) (JsonRef name) =+      '(JsonRef (LookupNewName name active), global)+++type family+    RenameObject+      (global :: Global)+      (active :: Active)+      (fields :: [FieldSpec])+      :: (Specification, Global)+  where+    RenameObject global active fields =+      RenameObject2+        (FoldReflectFields '( '[], global) active fields)+++type family+    RenameObject2+      (acc :: ([FieldSpec], Global))+      :: (Specification, Global)+  where+    RenameObject2 '(fields, global) =+      '(JsonObject (Reverse '[] fields), global)+++type family+    FoldReflectFields+      (   acc :: ([FieldSpec], Global))+      (active :: Active)+      (fields :: [FieldSpec])+      :: ([FieldSpec], Global)+  where+    FoldReflectFields '(acc, global) active '[] = '(acc, global)+    FoldReflectFields '(acc, global) active (field : more) =+      FoldReflectFields2+        acc+        active+        (ReflectField global active field)+        more+++type family+    FoldReflectFields2+      (   acc :: [FieldSpec])+      (active :: Active)+      ( field :: (FieldSpec, Global))+      (  more :: [FieldSpec])+      :: ([FieldSpec], Global)+  where+    FoldReflectFields2 acc active '(field, global) more =+      FoldReflectFields+        '(field : acc, global)+        active+        more+++type family+    ReflectField+      (global :: Global)+      (active :: Active)+      (field :: FieldSpec)+      :: (FieldSpec, Global)+  where+    ReflectField global active (Required name spec) =+      ReflectRequiredField+        name+        (FoldRename global active spec)+    ReflectField global active (Optional name spec) =+      ReflectOptionalField+        name+        (FoldRename global active spec)+++type family+    ReflectRequiredField+      (name :: Symbol)+      (spec :: (Specification, Global))+      :: (FieldSpec, Global)+  where+    ReflectRequiredField name '(spec, global) =+      '(Required name spec, global)+++type family+    ReflectOptionalField+      (name :: Symbol)+      (spec :: (Specification, Global))+      :: (FieldSpec, Global)+  where+    ReflectOptionalField name '(spec, global) =+      '(Optional name spec, global)+++type family+    RenameEither+      (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))+      :: (Specification, Global)+  where+    RenameEither3 left '(right, global) =+      '(JsonEither left right, global)+++type family+    UpdateGlobals+      (global :: Global)+      (  defs :: [(Symbol, Specification)])+      :: Global+  where+    UpdateGlobals global '[] = global+    UpdateGlobals (G global) ( '(name, spec) : more) =+      UpdateGlobals+        (G (IncrementName global name))+        more+++type family+    IncrementName+      (global :: [NameState])+      (  name :: Symbol)+      :: [NameState]+  where+    IncrementName '[] name = '[N name 0]+    IncrementName (N name ord : more) name =+      N name (ord + 1) : more+    IncrementName (N miss ord : more) name =+      N miss ord : IncrementName more name+++type family+    RenameLet+      (global :: Global) -- updated+      (active :: Active)+      (defs :: [(Symbol, Specification)])+      (spec :: Specification)+      :: (Specification, Global)+  where+    RenameLet global active defs spec =+      RenameLet2+        global+        (UpdateActives global active defs)+        defs+        spec+++type family+    RenameLet2+      (global :: Global) -- updated+      (active :: Active) -- updated+      (defs :: [(Symbol, Specification)])+      (spec :: Specification)+  where+    RenameLet2 global active defs spec =+      RenameLet3+        global+        active+        (RenameDefs global defs)+        spec+++type family+    RenameLet3+      (global :: Global)+      (active :: Active)+      (  defs :: [(Symbol, Specification)])+      (  spec :: Specification)+      :: (Specification, Global)+  where+    RenameLet3 global active defs spec =+      RenameLet4+        (ReflectDefs global active defs)+        active+        spec+++type family+    RenameLet4+      (     r :: (Global, [(Symbol, Specification)]))+      (active :: Active)+      (  spec :: Specification)+      :: (Specification, Global)+  where+    RenameLet4 '(global, defs) active spec =+      RenameLet5+        (FoldRename global active spec)+        defs+++type family+    RenameLet5+      (r :: (Specification, Global))+      (defs :: [(Symbol, Specification)])+      :: (Specification, Global)+  where+    RenameLet5 '(spec, global) defs =+      '(JsonLet defs spec, global)+++type family+    UpdateActives+      (global :: Global) -- already updated+      (active :: Active)+      (  defs :: [(Symbol, Specification)])+      :: Active+  where+    UpdateActives global active '[] = active+    UpdateActives global (A active) ( '(name, spec) : more) =+      UpdateActives+        global+        (A (SetActive global active name))+        more+++type family+    SetActive+      (global :: Global)+      (active :: [NameState])+      (  name :: Symbol)+      :: [NameState]+  where+    SetActive+        (G (N name ord : moreG))+        (N name x : moreA)+        name+      =+        (N name ord : moreA)+    SetActive+        (G (N name ord : moreG))+        (N miss x : moreA)+        name+      =+        N miss x : SetActive (G (N name ord : moreG)) moreA name+    SetActive+        (G (N name ord : moreG))+        '[]+        name+      =+        '[N name ord]+    SetActive+        (G (N miss x : moreG))+        active+        name+      =+        SetActive (G moreG) active name+++type family+    ReflectDefs+      (global :: Global)+      (active :: Active)+      (  defs :: [(Symbol, Specification)])+      :: (Global, [(Symbol, Specification)])+  where+    ReflectDefs global active defs =+      FoldReflectDefs '(global, '[]) active defs+++type family+    FoldReflectDefs+      (acc :: (Global, [(Symbol, Specification)]))+      (active :: Active)+      (defs :: [(Symbol, Specification)])+      :: (Global, [(Symbol, Specification)])+  where+    FoldReflectDefs acc active '[] = acc+    FoldReflectDefs+        '(global, acc)+        active+        ( '(name, spec) : more )+      =+        FoldReflectDefs2+          (FoldRename global active spec)+          active+          name+          acc+          more+++type family+    FoldReflectDefs2+      (  spec :: (Specification, Global))+      (active :: Active)+      (  name :: Symbol)+      (   acc :: [(Symbol, Specification)])+      (  more :: [(Symbol, Specification)])+      :: (Global, [(Symbol, Specification)])+  where+    FoldReflectDefs2 '(spec, global) active name acc more =+      FoldReflectDefs '(global, '(name, 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)]+  where+    RenameDefs globals '[] = '[]+    RenameDefs (G globals) ( '(name, spec) : more) =+      '(LookupNewName name globals, spec) : RenameDefs (G globals) more+++type family+    LookupNewName+      (target :: Symbol)+      ( names :: [NameState])+      :: Symbol+  where+    LookupNewName target (N target 0 : more) = target+    LookupNewName target (N target ord : more) =+      AppendSymbol target ( AppendSymbol "." ( ToSymbol ord))+    LookupNewName target (N miss ord : more) =+      LookupNewName target more+++type family+    ToSymbol+      (o :: Nat)+      :: Symbol+  where+    {-+      We _could_ do some fancy stuff with type level mod and division+      over Nat to handle an almost arbitrary number of name conflicts,+      but for now handling 50 levels of name conflict seems sufficient.+    -}+    ToSymbol 1 = "1"+    ToSymbol 2 = "2"+    ToSymbol 3 = "3"+    ToSymbol 4 = "4"+    ToSymbol 5 = "5"+    ToSymbol 6 = "6"+    ToSymbol 7 = "7"+    ToSymbol 8 = "8"+    ToSymbol 9 = "9"+    ToSymbol 10 = "10"+    ToSymbol 11 = "11"+    ToSymbol 12 = "12"+    ToSymbol 13 = "13"+    ToSymbol 14 = "14"+    ToSymbol 15 = "15"+    ToSymbol 16 = "16"+    ToSymbol 17 = "17"+    ToSymbol 18 = "18"+    ToSymbol 19 = "19"+    ToSymbol 20 = "20"+    ToSymbol 21 = "21"+    ToSymbol 22 = "22"+    ToSymbol 23 = "23"+    ToSymbol 24 = "24"+    ToSymbol 25 = "25"+    ToSymbol 26 = "26"+    ToSymbol 27 = "27"+    ToSymbol 28 = "28"+    ToSymbol 29 = "29"+    ToSymbol 30 = "30"+    ToSymbol 31 = "31"+    ToSymbol 32 = "32"+    ToSymbol 33 = "33"+    ToSymbol 34 = "34"+    ToSymbol 35 = "35"+    ToSymbol 36 = "36"+    ToSymbol 37 = "37"+    ToSymbol 38 = "38"+    ToSymbol 39 = "39"+    ToSymbol 40 = "40"+    ToSymbol 41 = "41"+    ToSymbol 42 = "42"+    ToSymbol 43 = "43"+    ToSymbol 44 = "44"+    ToSymbol 45 = "45"+    ToSymbol 46 = "46"+    ToSymbol 47 = "47"+    ToSymbol 48 = "48"+    ToSymbol 49 = "49"+    ToSymbol 50 = "50"+    ToSymbol 51 = "51"+    ToSymbol 52 = "52"+    ToSymbol 53 = "53"+    ToSymbol 54 = "54"+    ToSymbol 55 = "55"+    ToSymbol 56 = "56"+    ToSymbol 57 = "57"+    ToSymbol 58 = "58"+    ToSymbol 59 = "59"+    ToSymbol 60 = "60"+    ToSymbol 61 = "61"+    ToSymbol 62 = "62"+    ToSymbol 63 = "63"+    ToSymbol 64 = "64"+    ToSymbol 65 = "65"+    ToSymbol 66 = "66"+    ToSymbol 67 = "67"+    ToSymbol 68 = "68"+    ToSymbol 69 = "69"+    ToSymbol 70 = "70"+    ToSymbol 71 = "71"+    ToSymbol 72 = "72"+    ToSymbol 73 = "73"+    ToSymbol 74 = "74"+    ToSymbol 75 = "75"+    ToSymbol 76 = "76"+    ToSymbol 77 = "77"+    ToSymbol 78 = "78"+    ToSymbol 79 = "79"+    ToSymbol 80 = "80"+    ToSymbol 81 = "81"+    ToSymbol 82 = "82"+    ToSymbol 83 = "83"+    ToSymbol 84 = "84"+    ToSymbol 85 = "85"+    ToSymbol 86 = "86"+    ToSymbol 87 = "87"+    ToSymbol 88 = "88"+    ToSymbol 89 = "89"+    ToSymbol 90 = "90"+    ToSymbol 91 = "91"+    ToSymbol 92 = "92"+    ToSymbol 93 = "93"+    ToSymbol 94 = "94"+    ToSymbol 95 = "95"+    ToSymbol 96 = "96"+    ToSymbol 97 = "97"+    ToSymbol 98 = "98"+    ToSymbol 99 = "99"+    ToSymbol 100 = "100"++    ToSymbol a =+      TE.TypeError (+        TE.Text      "The author of json-spec-openapi was lazy and did"+        :$$: TE.Text "not foresee that anyone would write a specification"+        :$$: TE.Text "that would have to handle more than 100 collisions"+        :$$: TE.Text "for a single name when converting to an OpenApi"+        :$$: TE.Text "spec. Please submit a bug report on GitHub and"+        :$$: TE.Text "I'll add a fix."+      )+++type family+    MapSpec+      (f :: Specification -> Specification)+      (a :: (Specification, Global))+      :: (Specification, Global)+  where+    MapSpec f '(a, b) = '(f a, b)+++type family+    Reverse+      (acc  :: [FieldSpec])+      (list :: [FieldSpec])+      :: [FieldSpec]+  where+    Reverse acc '[] = acc+    Reverse acc (a : more) = Reverse (a : acc) more+++data NameState = N+  { _name :: Symbol+  ,  _ord :: Nat+  }+++newtype Global = G [NameState]+++newtype Active = A [NameState]++

@@ -7,6 +7,7 @@ {-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -14,19 +15,25 @@  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),-  Specification(JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt,-  JsonLet, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef,-  JsonString, JsonTag), unField)-import Data.JsonSpec.OpenApi (EncodingSchema, toOpenApiSchema)+import Data.JsonSpec+  ( Field(Field), FieldSpec(Optional, Required)+  , HasJsonDecodingSpec(DecodingSpec, fromJSONStructure)+  , HasJsonEncodingSpec(EncodingSpec, toJSONStructure), SpecJSON(SpecJSON)+  , Specification+    ( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet+    , JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag+    )+  , (:::), (::?), unField+  )+import Data.JsonSpec.OpenApi (EncodingSchema, Rename, toOpenApiSchema) import Data.OpenApi (Definitions, ToSchema) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) import Data.Time (UTCTime)-import Prelude (Applicative(pure), Bool(False), Functor(fmap),-  Maybe(Just), Monoid(mempty), ($), Eq, IO, Show)+import Prelude+  ( Applicative(pure), Bool(False), Functor(fmap), Maybe(Just), Monoid(mempty)+  , ($), (.), Eq, IO, Show+  ) import Test.Hspec (describe, hspec, it, shouldBe) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict.InsOrd as HMI@@ -78,9 +85,12 @@                         & set OA.properties (                             mempty                               & set (at "tag") (Just (OA.Inline (-                                  mempty & set OA.enum_ (Just [toJSON ("a" :: Text)])+                                  mempty+                                    & set OA.enum_ (Just [toJSON ("a" :: Text)])                                 )))-                              & set (at "content") (Just (OA.Inline stringSchema))+                              & set (at "content") (Just (+                                  OA.Inline stringSchema+                                ))                           )                         & set OA.required ["tag", "content"]                         & set@@ -92,9 +102,12 @@                         & set OA.properties (                             mempty                               & set (at "tag") (Just (OA.Inline (-                                  mempty & set OA.enum_ (Just [toJSON ("b" :: Text)])+                                  mempty+                                    & set OA.enum_ (Just [toJSON ("b" :: Text)])                                 )))-                              & set (at "content") (Just (OA.Inline stringSchema))+                              & set (at "content") (Just (+                                  OA.Inline stringSchema+                                ))                           )                         & set OA.required ["tag", "content"]                         & set@@ -191,7 +204,9 @@               in                 mempty                   & set OA.type_ (Just OA.OpenApiArray)-                  & set OA.items (Just (OA.OpenApiItemsObject (OA.Inline elementSchema)))+                  & set OA.items (Just (+                      OA.OpenApiItemsObject (OA.Inline elementSchema)+                    ))             )          in@@ -353,7 +368,273 @@                     (Just (OA.AdditionalPropertiesAllowed False))             )         in-          actual `shouldBe` expected+          Aeson.encode actual `shouldBe` Aeson.encode expected++      it "Mutual recursion" $+        let+          barSchema :: OA.Schema+          barSchema =+            mempty+              & set OA.type_ (Just OA.OpenApiObject)+              & set+                  OA.additionalProperties+                  (Just (OA.AdditionalPropertiesAllowed False))+              & set+                  OA.properties+                  (+                    HMI.fromList+                      [ ( "recbar"+                        , OA.Inline (+                            mempty+                              & set OA.type_ (Just OA.OpenApiArray)+                              & set+                                  OA.items+                                  (+                                    Just+                                    . OA.OpenApiItemsObject+                                    . OA.Ref+                                    . OA.Reference+                                    $ "foo"+                                  )+                          )+                        )+                      , ( "valbar"+                        , OA.Inline stringSchema+                        )+                      ]+                  )+              & set OA.required ["recbar", "valbar"]++          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( HMI.fromList+                [ ( "foo"+                  , mempty+                      & set OA.type_ (Just OA.OpenApiObject)+                      & set+                          OA.additionalProperties+                          (Just (OA.AdditionalPropertiesAllowed False))+                      & set+                          OA.properties+                          (+                            HMI.fromList+                              [ ( "recfoo"+                                , OA.Inline (+                                    mempty+                                      & set OA.type_ (Just OA.OpenApiArray)+                                      & set+                                          OA.items+                                          (+                                            Just+                                            . OA.OpenApiItemsObject+                                            . OA.Ref+                                            . OA.Reference+                                            $ "bar"+                                          )+                                  )+                                )+                              , ( "valfoo"+                                , OA.Inline (+                                    mempty+                                      & set OA.type_ (Just OA.OpenApiInteger)+                                  )+                                )+                              ]+                          )+                      & set OA.required ["recfoo", "valfoo"]+                  )+                , ( "bar"+                  , barSchema+                  )+                ]+            , barSchema+            )++          actual :: (Definitions OA.Schema, OA.Schema)+          actual =+            toOpenApiSchema (Proxy @(+              JsonLet+                '[ '( "foo"+                    , JsonObject+                        '[ "recfoo" ::: JsonArray (JsonRef "bar")+                         , "valfoo" ::: JsonInt+                         ]+                    )+                 , '( "bar"+                    , JsonObject+                        '[ "recbar" ::: JsonArray (JsonRef "foo")+                         , "valbar" ::: JsonString+                         ]+                    )+                 ]+                 (JsonRef "bar")+            ))+        in+          Aeson.encode actual `shouldBe` Aeson.encode expected++      it "Nested name conflict" $+        let+          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( mempty+                & set (at "foo.1") (Just (stringSchema))+                & set (at "foo") (Just (stringSchema))+            , stringSchema+            )++          actual :: (Definitions OA.Schema, OA.Schema)+          actual =+            toOpenApiSchema (Proxy @(Rename (+              JsonLet+                '[ '("foo"+                    , JsonLet+                        '[ '( "foo"+                            , JsonString+                            )+                         ]+                         (JsonRef "foo")+                    )+                 ]+                 (JsonRef "foo")+            )))+        in+          Aeson.encode actual `shouldBe` Aeson.encode expected++      it "Nested name conflict 2" $+        let+          expectedFooSchema :: OA.Schema+          expectedFooSchema =+            mempty+              & set OA.type_ (Just OA.OpenApiObject)+              & set+                  OA.additionalProperties+                  (Just (OA.AdditionalPropertiesAllowed False))+              & set OA.properties (+                  mempty+                    & set (at "field1") (Just (+                        OA.Ref (OA.Reference "foo.1")+                      ))+                    & set (at "field2") (Just (+                        OA.Ref (OA.Reference "bar")+                      ))+                )++          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( mempty+                & set (at "bar") (Just stringSchema)+                & set (at "foo.1") (Just stringSchema)+                & set (at "foo") (Just expectedFooSchema)+            , expectedFooSchema+            )++          actual :: (Definitions OA.Schema, OA.Schema)+          actual =+            toOpenApiSchema (Proxy @(Rename (+              JsonLet+                '[ '("foo"+                    , JsonLet+                        '[ '( "foo"+                            , JsonString+                            )+                         ]+                         (+                           JsonObject+                             '[ ("field1" ::? JsonRef "foo")+                              , ("field2" ::? JsonRef "bar")+                              ]+                         )+                    )+                 , '( "bar"+                    , JsonString+                    )+                 ]+                 (JsonRef "foo")+            )))+        in+          Aeson.encode actual `shouldBe` Aeson.encode expected++      it "Nested name conflict 3" $+        let+          expected :: (Definitions OA.Schema, OA.Schema)+          expected =+            ( mempty+                & set (at "foo.1") (Just stringSchema)+                & set (at "foo.2") (Just (+                    mempty & set OA.type_ (Just OA.OpenApiInteger)+                  ))+                & set (at "foo.3") (Just (+                    mempty & set OA.type_ (Just OA.OpenApiBoolean)+                  ))+                & set (at "foo") (Just (+                    mempty+                      & set OA.type_ (Just OA.OpenApiObject)+                      & set OA.properties (HMI.fromList+                          [ ("field1", OA.Ref (OA.Reference "foo.1"))+                          , ("field2", OA.Ref (OA.Reference "foo.2"))+                          , ("field3", OA.Ref (OA.Reference "foo.3"))+                          ]+                        )+                      & set OA.additionalProperties (Just (+                          OA.AdditionalPropertiesAllowed False+                        ))+                      & set OA.required ["field1", "field2", "field3"]+                  ))+                & set (at "foo.4") (Just (+                    mempty+                      & set OA.oneOf (+                          Just+                            [ OA.Inline $+                                mempty & set OA.type_ (Just OA.OpenApiNull)+                            , OA.Inline $ stringSchema+                            ]+                        )+                  ))+            , mempty+                & set OA.type_ (Just OA.OpenApiObject)+                & set OA.properties (HMI.fromList+                    [ ("field1", OA.Ref (OA.Reference "foo"))+                    , ("field2", OA.Ref (OA.Reference "foo.4"))+                    ]+                  )+                & set OA.required ["field1", "field2"]+                & set OA.additionalProperties (Just (+                    OA.AdditionalPropertiesAllowed False+                  ))+            )++          actual :: (Definitions OA.Schema, OA.Schema)+          actual =+            toOpenApiSchema (Proxy @(Rename (+              JsonLet+                '[ '( "foo"+                    , JsonLet+                        '[ '("foo", JsonString) ]+                         (+                           JsonObject+                            '[ "field1" ::: JsonRef "foo"+                             , "field2" ::: JsonLet+                                             '[ '("foo", JsonInt) ]+                                              (JsonRef "foo")+                             , "field3" ::: JsonLet+                                             '[ '("foo", JsonBool) ]+                                              (JsonRef "foo")+                             ]++                         )+                    )+                 ]+                 (+                   JsonObject+                     '[ "field1" ::: JsonRef "foo"+                      , "field2" ::: JsonLet+                                      '[ '("foo", JsonNullable JsonString) ]+                                       (JsonRef "foo")+                      ]+                 )+            )))+        in+          Aeson.encode actual `shouldBe` Aeson.encode expected      describe "EncodingSchema" $       it "works" $