@@ -2,14 +2,17 @@
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedStrings #-}
56{-# LANGUAGE PolyKinds #-}
67{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
79{-# LANGUAGE TypeOperators #-}
810{-# LANGUAGE TypeSynonymInstances #-}
911module Data.Swagger.Schema.Internal where
1012
1113import Control.Lens
1214import Data.Aeson
15+import Data.Char
1316import Data.HashMap.Strict (HashMap)
1417import Data.HashSet (HashSet)
1518import Data.Int
@@ -36,11 +39,19 @@ named name schema = (Just name, schema)
3639class ToSchema a where
3740 toNamedSchema :: proxy a -> NamedSchema
3841 default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
39− toNamedSchema = unnamed . genericToSchema defaultSchemaOptions
42+ toNamedSchema = genericToNamedSchema defaultSchemaOptions
43+
44+schemaName :: ToSchema a => proxy a -> Maybe String
45+schemaName = fst . toNamedSchema
4046
4147toSchema :: ToSchema a => proxy a -> Schema
4248toSchema = snd . toNamedSchema
4349
50+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
51+toSchemaRef proxy = case toNamedSchema proxy of
52+ (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
53+ (_, schema) -> Inline schema
54+
4455class GToSchema (f :: * -> *) where
4556 gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
4657
@@ -50,7 +61,7 @@ gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
5061instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
5162 toNamedSchema _ = unnamed $ mempty
5263 & schemaType .~ SchemaArray
53− & schemaItems ?~ SchemaItemsObject (Inline (toSchema (Proxy :: Proxy a)))
64+ & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
5465
5566instance {-# OVERLAPPING #-} ToSchema String where
5667 toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
@@ -154,26 +165,39 @@ genericToSchema opts = snd . genericToNamedSchema opts
154165genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
155166genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
156167
168+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
169+gdatatypeSchemaName opts _ = case name of
170+ (c:_) | isAlpha c && isUpper c -> Just name
171+ _ -> Nothing
172+ where
173+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
174+
157175instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
158176 gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
159177
160178-- | Single constructor data type.
161179instance {-# OVERLAPPABLE #-} (Datatype d, GToSchema f) => GToSchema (D1 d (C1 c f)) where
162− gtoNamedSchema opts _ = named schemaName . gtoSchema opts (Proxy :: Proxy f)
180+ gtoNamedSchema opts _ s = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
163181 where
164− schemaName = datatypeNameModifier opts $ datatypeName (Proxy3 :: Proxy3 d f p)
182+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
165183
166184-- | Single field single constructor data type.
167185instance (Datatype d, Selector s, GToSchema f) => GToSchema (D1 d (C1 c (S1 s f))) where
168186 gtoNamedSchema opts _ s
169− | unwrapUnaryRecords opts = named schemaName $ gtoSchema opts (Proxy :: Proxy f) s
170− | otherwise = named schemaName $
187+ | unwrapUnaryRecords opts = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
188+ | otherwise = (schemaName,) $
171189 case schema ^. schemaItems of
172− Just (SchemaItemsArray [Inline fieldSchema]) -> fieldSchema
190+ Just (SchemaItemsArray [_]) -> fieldSchema
173191 _ -> schema
174192 where
175− schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
176− schemaName = datatypeNameModifier opts $ datatypeName (Proxy3 :: Proxy3 d f p)
193+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
194+ schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
195+ fieldSchema = gtoSchema opts (Proxy :: Proxy f) s
196+
197+gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema
198+gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of
199+ (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
200+ (_, schema) -> Inline schema
177201
178202appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
179203appendItem x Nothing = Just (SchemaItemsArray [x])
@@ -184,16 +208,16 @@ withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions
184208withFieldSchema opts _ isRequiredField schema
185209 | T.null fieldName = schema
186210 & schemaType .~ SchemaArray
187− & schemaItems %~ appendItem (Inline fieldSchema)
211+ & schemaItems %~ appendItem fieldSchemaRef
188212 | otherwise = schema
189213 & schemaType .~ SchemaObject
190− & schemaProperties . at fieldName ?~ Inline fieldSchema
214+ & schemaProperties . at fieldName ?~ fieldSchemaRef
191215 & if isRequiredField
192216 then schemaRequired %~ (fieldName :)
193217 else id
194218 where
195219 fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
196− fieldSchema = gtoSchema opts (Proxy :: Proxy f) mempty
220+ fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f)
197221
198222-- | Optional record fields.
199223instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
@@ -204,7 +228,7 @@ instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) wh
204228 gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
205229
206230instance ToSchema c => GToSchema (K1 i c) where
207− gtoNamedSchema _ _ _ = unnamed $ toSchema (Proxy :: Proxy c)
231+ gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
208232
209233data Proxy2 a b = Proxy2
210234