@@ -25,48 +25,62 @@ import GHC.Generics
2525import Data.Swagger.Internal
2626import Data.Swagger.Lens
2727
28+type NamedSchema = (Maybe String, Schema)
29+
30+unnamed :: Schema -> NamedSchema
31+unnamed schema = (Nothing, schema)
32+
33+named :: String -> Schema -> NamedSchema
34+named name schema = (Just name, schema)
35+
2836class ToSchema a where
29− toSchema :: proxy a -> Schema
30− default toSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Schema
31− toSchema = genericToSchema defaultSchemaOptions
37+ toNamedSchema :: proxy a -> NamedSchema
38+ default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
39+ toNamedSchema = unnamed . genericToSchema defaultSchemaOptions
40+
41+toSchema :: ToSchema a => proxy a -> Schema
42+toSchema = snd . toNamedSchema
3243
3344class GToSchema (f :: * -> *) where
34− gtoSchema :: SchemaOptions -> proxy f -> Schema -> Schema
45+ gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
46+
47+gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
48+gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
3549
3650instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
37− toSchema _ = mempty
51+ toNamedSchema _ = unnamed $ mempty
3852 & schemaType .~ SchemaArray
3953 & schemaItems ?~ SchemaItemsObject (Inline (toSchema (Proxy :: Proxy a)))
4054
4155instance {-# OVERLAPPING #-} ToSchema String where
42− toSchema _ = mempty & schemaType .~ SchemaString
56+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
4357
4458instance ToSchema Bool where
45− toSchema _ = mempty & schemaType .~ SchemaBoolean
59+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaBoolean
4660
4761instance ToSchema Integer where
48− toSchema _ = mempty & schemaType .~ SchemaInteger
62+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaInteger
4963
50−instance ToSchema Int where toSchema = toSchemaBoundedIntegral
51−instance ToSchema Int8 where toSchema = toSchemaBoundedIntegral
52−instance ToSchema Int16 where toSchema = toSchemaBoundedIntegral
53−instance ToSchema Int32 where toSchema = toSchemaBoundedIntegral
54−instance ToSchema Int64 where toSchema = toSchemaBoundedIntegral
64+instance ToSchema Int where toNamedSchema = unnamed . toSchemaBoundedIntegral
65+instance ToSchema Int8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
66+instance ToSchema Int16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
67+instance ToSchema Int32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
68+instance ToSchema Int64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
5569
56−instance ToSchema Word where toSchema = toSchemaBoundedIntegral
57−instance ToSchema Word8 where toSchema = toSchemaBoundedIntegral
58−instance ToSchema Word16 where toSchema = toSchemaBoundedIntegral
59−instance ToSchema Word32 where toSchema = toSchemaBoundedIntegral
60−instance ToSchema Word64 where toSchema = toSchemaBoundedIntegral
70+instance ToSchema Word where toNamedSchema = unnamed . toSchemaBoundedIntegral
71+instance ToSchema Word8 where toNamedSchema = unnamed . toSchemaBoundedIntegral
72+instance ToSchema Word16 where toNamedSchema = unnamed . toSchemaBoundedIntegral
73+instance ToSchema Word32 where toNamedSchema = unnamed . toSchemaBoundedIntegral
74+instance ToSchema Word64 where toNamedSchema = unnamed . toSchemaBoundedIntegral
6175
6276instance ToSchema Double where
63− toSchema _ = mempty & schemaType .~ SchemaNumber
77+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
6478
6579instance ToSchema Float where
66− toSchema _ = mempty & schemaType .~ SchemaNumber
80+ toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaNumber
6781
6882instance ToSchema a => ToSchema (Maybe a) where
69− toSchema _ = toSchema (Proxy :: Proxy a)
83+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
7084
7185instance (ToSchema a, ToSchema b) => ToSchema (a, b)
7286instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
@@ -76,45 +90,47 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
7690instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
7791
7892instance ToSchema T.Text where
79− toSchema _ = toSchema (Proxy :: Proxy String)
93+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
8094
8195instance ToSchema TL.Text where
82− toSchema _ = toSchema (Proxy :: Proxy String)
96+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy String)
8397
8498instance ToSchema a => ToSchema (Map String a) where
85− toSchema _ = mempty
99+ toNamedSchema _ = unnamed $ mempty
86100 & schemaType .~ SchemaObject
87101 & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
88102
89−instance ToSchema a => ToSchema (Map T.Text a) where toSchema _ = toSchema (Proxy :: Proxy (Map String a))
90−instance ToSchema a => ToSchema (Map TL.Text a) where toSchema _ = toSchema (Proxy :: Proxy (Map String a))
103+instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
104+instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
91105
92−instance ToSchema a => ToSchema (HashMap String a) where toSchema _ = toSchema (Proxy :: Proxy (Map String a))
93−instance ToSchema a => ToSchema (HashMap T.Text a) where toSchema _ = toSchema (Proxy :: Proxy (Map String a))
94−instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchema _ = toSchema (Proxy :: Proxy (Map String a))
106+instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
107+instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
108+instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
95109
96110instance ToSchema a => ToSchema (Set a) where
97− toSchema _ = toSchema (Proxy :: Proxy [a])
111+ toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a])
98112 & schemaUniqueItems ?~ True
99113
100−instance ToSchema a => ToSchema (HashSet a) where toSchema _ = toSchema (Proxy :: Proxy (Set a))
114+instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
101115
102−instance ToSchema All where toSchema _ = toSchema (Proxy :: Proxy Bool)
103−instance ToSchema Any where toSchema _ = toSchema (Proxy :: Proxy Bool)
104−instance ToSchema a => ToSchema (Sum a) where toSchema _ = toSchema (Proxy :: Proxy a)
105−instance ToSchema a => ToSchema (Product a) where toSchema _ = toSchema (Proxy :: Proxy a)
106−instance ToSchema a => ToSchema (First a) where toSchema _ = toSchema (Proxy :: Proxy a)
107−instance ToSchema a => ToSchema (Last a) where toSchema _ = toSchema (Proxy :: Proxy a)
108−instance ToSchema a => ToSchema (Dual a) where toSchema _ = toSchema (Proxy :: Proxy a)
116+instance ToSchema All where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
117+instance ToSchema Any where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy Bool)
118+instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
119+instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
120+instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
121+instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
122+instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
109123
110124data SchemaOptions = SchemaOptions
111125 { fieldLabelModifier :: String -> String
126+ , datatypeNameModifier :: String -> String
112127 , unwrapUnaryRecords :: Bool
113128 }
114129
115130defaultSchemaOptions :: SchemaOptions
116131defaultSchemaOptions = SchemaOptions
117132 { fieldLabelModifier = id
133+ , datatypeNameModifier = id
118134 , unwrapUnaryRecords = False
119135 }
120136
@@ -129,25 +145,35 @@ toSchemaBoundedEnum _ = mempty
129145 & schemaType .~ SchemaString
130146 & schemaEnum ?~ map toJSON [minBound..maxBound :: a]
131147
132−genericToSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
133−genericToSchema opts _ = gtoSchema opts (Proxy :: Proxy (Rep a)) mempty
148+genericToNamedSchemaBoundedEnum :: (ToJSON a, Bounded a, Enum a, Generic a) => proxy a -> NamedSchema
149+genericToNamedSchemaBoundedEnum = unnamed . toSchemaBoundedEnum
150+
151+genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
152+genericToSchema opts = snd . genericToNamedSchema opts
153+
154+genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
155+genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
134156
135157instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
136− gtoSchema opts _ = gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
158+ gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
137159
138160-- | Single constructor data type.
139−instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (D1 d (C1 c f)) where
140− gtoSchema opts _ = gtoSchema opts (Proxy :: Proxy f)
161+instance {-# OVERLAPPABLE #-} (Datatype d, GToSchema f) => GToSchema (D1 d (C1 c f)) where
162+ gtoNamedSchema opts _ = named schemaName . gtoSchema opts (Proxy :: Proxy f)
163+ where
164+ schemaName = datatypeNameModifier opts $ datatypeName (Proxy3 :: Proxy3 d f p)
141165
142166-- | Single field single constructor data type.
143−instance (Selector s, GToSchema f) => GToSchema (D1 d (C1 c (S1 s f))) where
144− gtoSchema opts _ s
145− | unwrapUnaryRecords opts = gtoSchema opts (Proxy :: Proxy f) s
146− | otherwise = case schema ^. schemaItems of
147− Just (SchemaItemsArray [Inline fieldSchema]) -> fieldSchema
148− _ -> schema
167+instance (Datatype d, Selector s, GToSchema f) => GToSchema (D1 d (C1 c (S1 s f))) where
168+ gtoNamedSchema opts _ s
169+ | unwrapUnaryRecords opts = named schemaName $ gtoSchema opts (Proxy :: Proxy f) s
170+ | otherwise = named schemaName $
171+ case schema ^. schemaItems of
172+ Just (SchemaItemsArray [Inline fieldSchema]) -> fieldSchema
173+ _ -> schema
149174 where
150175 schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
176+ schemaName = datatypeNameModifier opts $ datatypeName (Proxy3 :: Proxy3 d f p)
151177
152178appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
153179appendItem x Nothing = Just (SchemaItemsArray [x])
@@ -171,14 +197,14 @@ withFieldSchema opts _ isRequiredField schema
171197
172198-- | Optional record fields.
173199instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
174− gtoSchema opts _ = withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
200+ gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
175201
176202-- | Record fields.
177203instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
178− gtoSchema opts _ = withFieldSchema opts (Proxy2 :: Proxy2 s f) True
204+ gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
179205
180206instance ToSchema c => GToSchema (K1 i c) where
181− gtoSchema _ _ _ = toSchema (Proxy :: Proxy c)
207+ gtoNamedSchema _ _ _ = unnamed $ toSchema (Proxy :: Proxy c)
182208
183209data Proxy2 a b = Proxy2
184210