@@ -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,7 +136,7 @@ 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
@@ -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,7 +611,7 @@ 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)
@@ -627,12 +628,18 @@ 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, ToSchema b) => ToSchema (a, b)
631−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
632−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
633−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
634−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
635−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
631+instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
632+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
633+instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
634+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
635+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
636+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
637+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
638+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
639+instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
640+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
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
642+ declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
636643
637644timeSchema :: T.Text -> Schema
638645timeSchema fmt = mempty
@@ -651,7 +658,7 @@ instance ToSchema LocalTime where
651658 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
652659 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
653660
654−-- | 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.
655662instance ToSchema ZonedTime where
656663 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
657664 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
@@ -683,7 +690,7 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
683690instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
684691
685692-- | NOTE: This schema does not account for the uniqueness of keys.
686−instance ToSchema a => ToSchema (IntMap a) where
693+instance (ToSchema a) => ToSchema (IntMap a) where
687694 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
688695
689696instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
@@ -804,13 +811,13 @@ declareSchemaBoundedEnumKeyMapping :: forall map key value.
804811 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
805812 => Proxy (map key value) -> Declare (Definitions Schema) Schema
806813declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
807− ToJSONKeyText keyToText _ -> objectSchema keyToText
814+ ToJSONKeyText getKey _ -> objectSchema getKey
808815 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
809816 where
810− objectSchema keyToText = do
817+ objectSchema getKey = do
811818 valueRef <- declareSchemaRef (Proxy :: Proxy value)
812819 let allKeys = [minBound..maxBound :: key]
813− mkPair k = (keyToText k, valueRef)
820+ mkPair k = (keyToText $ getKey k, valueRef)
814821 return $ mempty
815822 & type_ ?~ OpenApiObject
816823 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
@@ -853,7 +860,7 @@ toSchemaBoundedEnumKeyMapping :: forall map key value.
853860toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
854861
855862-- | A configurable generic @'Schema'@ creator.
856−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) =>
863+genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
857864 SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
858865genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
859866
@@ -861,9 +868,24 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche
861868-- This function applied to @'defaultSchemaOptions'@
862869-- is used as the default for @'declareNamedSchema'@
863870-- when the type is an instance of @'Generic'@.
864−genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) =>
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"
879+genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
865880 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
866−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
881+genericDeclareNamedSchema opts _ =
882+ rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
883+ where
884+ unspace ' ' = '_'
885+ unspace x = x
886+ orig = fmap unspace $ show $ typeRep @a
887+ name = datatypeNameModifier opts orig
888+
867889
868890-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
869891genericNameSchema :: forall a d f.
@@ -923,10 +945,13 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
923945 case schema ^. items of
924946 Just (OpenApiItemsArray [_]) -> fieldSchema
925947 _ -> do
926− declare defs
927− 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')
928953 where
929− (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
954+ (_, NamedSchema _ schema) = runDeclare recordSchema mempty
930955 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
931956 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
932957
@@ -1089,49 +1114,6 @@ data Proxy2 a b = Proxy2
10891114
10901115data Proxy3 a b c = Proxy3
10911116
1092−-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
1093−--
1094−-- Intended usage:
1095−--
1096−-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1097−-- >>> :{
1098−-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
1099−-- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
1100−-- :}
1101−--
1102−-- >>> toNamedSchema @(Foo Int) Proxy ^. name
1103−-- Just "Foo_Int"
1104−-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
1105−-- Just "Foo_Bool"
1106−-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
1107−-- Just "Foo_(Foo_Text)"
1108−class ToSchema1 (f :: * -> *) where
1109− declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1110−
1111− -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
1112− -- above, however sadly GHC does not like it.
1113− default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1114− declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
1115−
1116−{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
1117−using 'ToSchema1' instance, like this:
1118−
1119−#if __GLASGOW_HASKELL__ >= 806
1120−>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1121−>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1122−#else
1123−> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1124−> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1125−#endif
1126−-}
1127−newtype BySchema1 f a = BySchema1 (f a)
1128−
1129−instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where
1130− declareNamedSchema _ = do
1131− sch <- declareNamedSchema1 @f @a Proxy Proxy
1132− let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
1133− return $ rename (Just tName) sch
1134−
11351117{- $setup
11361118>>> import Data.OpenApi
11371119>>> import Data.Aeson (encode)
@@ -1141,7 +1123,4 @@ instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToS
11411123>>> :set -XDeriveAnyClass
11421124>>> :set -XStandaloneDeriving
11431125>>> :set -XTypeApplications
1144−#if __GLASGOW_HASKELL__ >= 806
1145−>>> :set -XDerivingVia
1146−#endif
11471126-}