@@ -64,13 +64,14 @@ import GHC.Generics
6464import qualified Data.UUID.Types as UUID
6565import Type.Reflection (Typeable, typeRep)
6666
67−import Data.OpenApi.Declare
68−import Data.OpenApi.Internal
69−import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
70−import Data.OpenApi.Lens hiding (name, schema)
71−import qualified Data.OpenApi.Lens as Swagger
72−import Data.OpenApi.SchemaOptions
73−import Data.OpenApi.Internal.TypeShape
67+import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)
68+import Data.OpenApi.Declare
69+import Data.OpenApi.Internal
70+import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
71+import Data.OpenApi.Internal.TypeShape
72+import Data.OpenApi.Lens hiding (name, schema)
73+import qualified Data.OpenApi.Lens as Swagger
74+import Data.OpenApi.SchemaOptions
7475
7576import qualified Data.ByteString as BS
7677import qualified Data.ByteString.Lazy.Char8 as BSL
@@ -135,13 +136,13 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
135136--
136137-- instance ToSchema Coord
137138-- @
138−class ToSchema a where
139+class Typeable a => ToSchema a where
139140 -- | Convert a type into an optionally named schema
140141 -- together with all used definitions.
141142 -- Note that the schema itself is included in definitions
142143 -- only if it is recursive (and thus needs its definition in scope).
143144 declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
144− default declareNamedSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
145+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) =>
145146 Proxy a -> Declare (Definitions Schema) NamedSchema
146147 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
147148
@@ -405,8 +406,8 @@ sketchSchema = sketch . toJSON
405406 _ -> Nothing
406407 go (Object o) = mempty
407408 & type_ ?~ OpenApiObject
408− & required .~ sort (HashMap.keys o)
409− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
409+ & required .~ sort (objectKeys o)
410+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
410411
411412-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
412413-- Produced schema uses as much constraints as possible.
@@ -570,12 +571,12 @@ sketchStrictSchema = go . toJSON
570571 go js@(Object o) = mempty
571572 & type_ ?~ OpenApiObject
572573 & required .~ sort names
573− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
574+ & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
574575 & maxProperties ?~ fromIntegral (length names)
575576 & minProperties ?~ fromIntegral (length names)
576577 & enum_ ?~ [js]
577578 where
578− names = HashMap.keys o
579+ names = objectKeys o
579580
580581class GToSchema (f :: * -> *) where
581582 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
@@ -610,12 +611,12 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
610611instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
611612instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
612613
613−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
614+instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
614615
615616instance ToSchema a => ToSchema (Maybe a) where
616617 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
617618
618−instance (ToSchema a, ToSchema b, Typeable a, Typeable b) => ToSchema (Either a b) where
619+instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
619620 -- To match Aeson instance
620621 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField }
621622
@@ -627,17 +628,17 @@ instance ToSchema UUID.UUID where
627628 declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
628629 & example ?~ toJSON (UUID.toText UUID.nil)
629630
630−instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) where
631+instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
631632 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
632−instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) where
633+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
633634 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
634−instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) where
635+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
635636 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
636−instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e) => ToSchema (a, b, c, d, e) where
637+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
637638 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
638−instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f) => ToSchema (a, b, c, d, e, f) where
639+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
639640 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
640−instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f, ToSchema g, Typeable g) => ToSchema (a, b, c, d, e, f, g) where
641+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
641642 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
642643
643644timeSchema :: T.Text -> Schema
@@ -657,7 +658,7 @@ instance ToSchema LocalTime where
657658 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
658659 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
659660
660−-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
661+-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
661662instance ToSchema ZonedTime where
662663 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
663664 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
@@ -689,10 +690,10 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
689690instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
690691
691692-- | NOTE: This schema does not account for the uniqueness of keys.
692−instance (ToSchema a, Typeable a) => ToSchema (IntMap a) where
693+instance (ToSchema a) => ToSchema (IntMap a) where
693694 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
694695
695−instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (Map k v) where
696+instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
696697 declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
697698 ToJSONKeyText _ _ -> declareObjectMapSchema
698699 ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
@@ -703,7 +704,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSche
703704 & type_ ?~ OpenApiObject
704705 & additionalProperties ?~ AdditionalPropertiesSchema schema
705706
706−instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (HashMap k v) where
707+instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
707708 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
708709
709710instance {-# OVERLAPPING #-} ToSchema Object where
@@ -807,16 +808,16 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$>
807808-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
808809-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
809810declareSchemaBoundedEnumKeyMapping :: forall map key value.
810− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value)
811+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
811812 => Proxy (map key value) -> Declare (Definitions Schema) Schema
812813declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
813− ToJSONKeyText keyToText _ -> objectSchema keyToText
814+ ToJSONKeyText getKey _ -> objectSchema getKey
814815 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
815816 where
816− objectSchema keyToText = do
817+ objectSchema getKey = do
817818 valueRef <- declareSchemaRef (Proxy :: Proxy value)
818819 let allKeys = [minBound..maxBound :: key]
819− mkPair k = (keyToText k, valueRef)
820+ mkPair k = (keyToText $ getKey k, valueRef)
820821 return $ mempty
821822 & type_ ?~ OpenApiObject
822823 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
@@ -854,7 +855,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
854855-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
855856-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
856857toSchemaBoundedEnumKeyMapping :: forall map key value.
857− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value)
858+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
858859 => Proxy (map key value) -> Schema
859860toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
860861
@@ -867,6 +868,14 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche
867868-- This function applied to @'defaultSchemaOptions'@
868869-- is used as the default for @'declareNamedSchema'@
869870-- when the type is an instance of @'Generic'@.
871+--
872+-- Default implementation will use the name from 'Typeable' instance, including concrete
873+-- instantioations of type variables.
874+--
875+-- For example:
876+--
877+-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
878+-- Just "Either_Int_Bool"
870879genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
871880 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
872881genericDeclareNamedSchema opts _ =
@@ -936,10 +945,13 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
936945 case schema ^. items of
937946 Just (OpenApiItemsArray [_]) -> fieldSchema
938947 _ -> do
939− declare defs
940− return (unnamed schema)
948+ -- We have to run recordSchema instead of just using its defs,
949+ -- since those can be recursive and will lead to infinite loop,
950+ -- see https://github.com/biocad/openapi3/pull/37
951+ NamedSchema _ schema' <- recordSchema
952+ return (unnamed schema')
941953 where
942− (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
954+ (_, NamedSchema _ schema) = runDeclare recordSchema mempty
943955 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
944956 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
945957
@@ -1102,49 +1114,6 @@ data Proxy2 a b = Proxy2
11021114
11031115data Proxy3 a b c = Proxy3
11041116
1105−-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
1106−--
1107−-- Intended usage:
1108−--
1109−-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1110−-- >>> :{
1111−-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
1112−-- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
1113−-- :}
1114−--
1115−-- >>> toNamedSchema @(Foo Int) Proxy ^. name
1116−-- Just "Foo_Int"
1117−-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
1118−-- Just "Foo_Bool"
1119−-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
1120−-- Just "Foo_(Foo_Text)"
1121−class ToSchema1 (f :: * -> *) where
1122− declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a, Typeable a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1123−
1124− -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
1125− -- above, however sadly GHC does not like it.
1126− default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a)), Typeable (f a)) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1127− declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
1128−
1129−{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
1130−using 'ToSchema1' instance, like this:
1131−
1132−#if __GLASGOW_HASKELL__ >= 806
1133−>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1134−>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1135−#else
1136−> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1137−> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1138−#endif
1139−-}
1140−newtype BySchema1 f a = BySchema1 (f a)
1141−
1142−instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a, Typeable a) => ToSchema (BySchema1 f a) where
1143− declareNamedSchema _ = do
1144− sch <- declareNamedSchema1 @f @a Proxy Proxy
1145− let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
1146− return $ rename (Just tName) sch
1147−
11481117{- $setup
11491118>>> import Data.OpenApi
11501119>>> import Data.Aeson (encode)
@@ -1154,7 +1123,4 @@ instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToS
11541123>>> :set -XDeriveAnyClass
11551124>>> :set -XStandaloneDeriving
11561125>>> :set -XTypeApplications
1157−#if __GLASGOW_HASKELL__ >= 806
1158−>>> :set -XDerivingVia
1159−#endif
11601126-}