git.iko.soy/typeable/openapi3
on master help sign in
Use when possible and name only alphanumeric data types (e.g. don't name tuples)
63eb7eeNickolay Kudasov
src/Data/Swagger/Schema.hs+3−1
compare with master
unifiedsplit
@@ -1,6 +1,8 @@
1module Data.Swagger.Schema (
1module Data.Swagger.Schema (
2− toSchema,
3 ToSchema(..),
2 ToSchema(..),
3+ toSchema,
4+ toSchemaRef,
5+ schemaName,
4
6
5 SchemaOptions(..),
7 SchemaOptions(..),
6 defaultSchemaOptions,
8 defaultSchemaOptions,
src/Data/Swagger/Schema/Internal.hs+37−13
@@ -2,14 +2,17 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE PolyKinds #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE TypeSynonymInstances #-}
10{-# LANGUAGE TypeSynonymInstances #-}
9module Data.Swagger.Schema.Internal where
11module Data.Swagger.Schema.Internal where
10
12
11import Control.Lens
13import Control.Lens
12import Data.Aeson
14import Data.Aeson
15+import Data.Char
13import Data.HashMap.Strict (HashMap)
16import Data.HashMap.Strict (HashMap)
14import Data.HashSet (HashSet)
17import Data.HashSet (HashSet)
15import Data.Int
18import Data.Int
@@ -36,11 +39,19 @@ named name schema = (Just name, schema)
36class ToSchema a where
39class ToSchema a where
37 toNamedSchema :: proxy a -> NamedSchema
40 toNamedSchema :: proxy a -> NamedSchema
38 default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
41 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
40
46
41toSchema :: ToSchema a => proxy a -> Schema
47toSchema :: ToSchema a => proxy a -> Schema
42toSchema = snd . toNamedSchema
48toSchema = snd . toNamedSchema
43
49
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+
44class GToSchema (f :: * -> *) where
55class GToSchema (f :: * -> *) where
45 gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
56 gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
46
57
@@ -50,7 +61,7 @@ gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
50instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
61instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
51 toNamedSchema _ = unnamed $ mempty
62 toNamedSchema _ = unnamed $ mempty
52 & schemaType .~ SchemaArray
63 & schemaType .~ SchemaArray
53− & schemaItems ?~ SchemaItemsObject (Inline (toSchema (Proxy :: Proxy a)))
64+ & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
54
65
55instance {-# OVERLAPPING #-} ToSchema String where
66instance {-# OVERLAPPING #-} ToSchema String where
56 toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
67 toNamedSchema _ = unnamed $ mempty & schemaType .~ SchemaString
@@ -154,26 +165,39 @@ genericToSchema opts = snd . genericToNamedSchema opts
154genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
165genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
155genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
166genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
156
167
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+
157instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
175instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
158 gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
176 gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
159
177
160-- | Single constructor data type.
178-- | Single constructor data type.
161instance {-# OVERLAPPABLE #-} (Datatype d, GToSchema f) => GToSchema (D1 d (C1 c f)) where
179instance {-# 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)
163 where
181 where
164− schemaName = datatypeNameModifier opts $ datatypeName (Proxy3 :: Proxy3 d f p)
182+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
165
183
166-- | Single field single constructor data type.
184-- | Single field single constructor data type.
167instance (Datatype d, Selector s, GToSchema f) => GToSchema (D1 d (C1 c (S1 s f))) where
185instance (Datatype d, Selector s, GToSchema f) => GToSchema (D1 d (C1 c (S1 s f))) where
168 gtoNamedSchema opts _ s
186 gtoNamedSchema opts _ s
169− | unwrapUnaryRecords opts = named schemaName $ gtoSchema opts (Proxy :: Proxy f) s
187+ | unwrapUnaryRecords opts = (schemaName, gtoSchema opts (Proxy :: Proxy f) s)
170− | otherwise = named schemaName $
188+ | otherwise = (schemaName,) $
171 case schema ^. schemaItems of
189 case schema ^. schemaItems of
172− Just (SchemaItemsArray [Inline fieldSchema]) -> fieldSchema
190+ Just (SchemaItemsArray [_]) -> fieldSchema
173 _ -> schema
191 _ -> schema
174 where
192 where
175− schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
193+ schemaName = gdatatypeSchemaName opts (Proxy :: Proxy d)
176− schemaName = datatypeNameModifier opts $ datatypeName (Proxy3 :: Proxy3 d f p)
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
177
201
178appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
202appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
179appendItem x Nothing = Just (SchemaItemsArray [x])
203appendItem x Nothing = Just (SchemaItemsArray [x])
@@ -184,16 +208,16 @@ withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions
184withFieldSchema opts _ isRequiredField schema
208withFieldSchema opts _ isRequiredField schema
185 | T.null fieldName = schema
209 | T.null fieldName = schema
186 & schemaType .~ SchemaArray
210 & schemaType .~ SchemaArray
187− & schemaItems %~ appendItem (Inline fieldSchema)
211+ & schemaItems %~ appendItem fieldSchemaRef
188 | otherwise = schema
212 | otherwise = schema
189 & schemaType .~ SchemaObject
213 & schemaType .~ SchemaObject
190− & schemaProperties . at fieldName ?~ Inline fieldSchema
214+ & schemaProperties . at fieldName ?~ fieldSchemaRef
191 & if isRequiredField
215 & if isRequiredField
192 then schemaRequired %~ (fieldName :)
216 then schemaRequired %~ (fieldName :)
193 else id
217 else id
194 where
218 where
195 fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
219 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)
197
221
198-- | Optional record fields.
222-- | Optional record fields.
199instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
223instance {-# 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
204 gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
228 gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
205
229
206instance ToSchema c => GToSchema (K1 i c) where
230instance ToSchema c => GToSchema (K1 i c) where
207− gtoNamedSchema _ _ _ = unnamed $ toSchema (Proxy :: Proxy c)
231+ gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
208
232
209data Proxy2 a b = Proxy2
233data Proxy2 a b = Proxy2
210
234