git.iko.soy/typeable/openapi3
on master help sign in
Merge pull request #19 from GetShopTV/definitions-#13
bb33aebNickolay Kudasov
src/Data/Swagger/Declare.hsnew file+105
compare with master
unifiedsplit
@@ -0,0 +1,105 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+module Data.Swagger.Declare where
6+
7+import Control.Monad
8+import Control.Monad.Trans
9+import Data.Functor.Identity
10+import Data.Monoid
11+
12+-- | A declare monad transformer parametrized by:
13+--
14+-- * @d@ — the output to accumulate (declarations);
15+--
16+-- * @m@ — the inner monad.
17+--
18+-- This monad transformer is similar to both state and writer monad transformers.
19+-- Thus it can be seen as
20+--
21+-- * a restricted append-only version of a state monad transformer or
22+--
23+-- * a writer monad transformer with the extra ability to read all previous output.
24+newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
25+ deriving (Functor)
26+
27+instance (Monad m, Monoid d) => Applicative (DeclareT d m) where
28+ pure x = DeclareT (\_ -> pure (mempty, x))
29+ DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
30+ ~(d', f) <- df d
31+ ~(d'', x) <- dx (d <> d')
32+ return (d' <> d'', f x)
33+
34+instance (Monad m, Monoid d) => Monad (DeclareT d m) where
35+ return x = DeclareT (\_ -> pure (mempty, x))
36+ DeclareT dx >>= f = DeclareT $ \d -> do
37+ ~(d', x) <- dx d
38+ ~(d'', y) <- runDeclareT (f x) (d <> d')
39+ return (d' <> d'', y)
40+
41+instance Monoid d => MonadTrans (DeclareT d) where
42+ lift m = DeclareT (\_ -> (,) mempty <$> m)
43+
44+-- |
45+-- Definitions of @declare@ and @look@ must satisfy the following laws:
46+--
47+-- [/monoid homomorphism (mempty)/]
48+-- @'declare' mempty == return ()@
49+--
50+-- [/monoid homomorphism (mappend)/]
51+-- @'declare' x >> 'declare' y == 'declare' (x <> y)@
52+-- for every @x@, @y@
53+--
54+-- [/@declare@-@look@/]
55+-- @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@
56+-- for every @x@
57+--
58+-- [/@look@ as left identity/]
59+-- @'look' >> m == m@
60+-- for every @m@
61+class Monad m => MonadDeclare d m | m -> d where
62+ -- | @'declare' x@ is an action that produces the output @x@.
63+ declare :: d -> m ()
64+ -- | @'look'@ is an action that returns all the output so far.
65+ look :: m d
66+
67+instance (Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
68+ declare d = DeclareT (\_ -> return (d, ()))
69+ look = DeclareT (\d -> return (mempty, d))
70+
71+-- | Retrieve a function of all the output so far.
72+looks :: MonadDeclare d m => (d -> a) -> m a
73+looks f = f <$> look
74+
75+evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
76+evalDeclareT (DeclareT f) d = snd `liftM` f d
77+
78+execDeclareT :: Monad m => DeclareT d m a -> d -> m d
79+execDeclareT (DeclareT f) d = fst `liftM` f d
80+
81+undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
82+undeclareT = flip evalDeclareT mempty
83+
84+-- | A declare monad parametrized by @d@ — the output to accumulate (declarations).
85+--
86+-- This monad is similar to both state and writer monads.
87+-- Thus it can be seen as
88+--
89+-- * a restricted append-only version of a state monad or
90+--
91+-- * a writer monad with the extra ability to read all previous output.
92+type Declare d = DeclareT d Identity
93+
94+runDeclare :: Declare d a -> d -> (d, a)
95+runDeclare m = runIdentity . runDeclareT m
96+
97+evalDeclare :: Declare d a -> d -> a
98+evalDeclare m = runIdentity . evalDeclareT m
99+
100+execDeclare :: Declare d a -> d -> d
101+execDeclare m = runIdentity . execDeclareT m
102+
103+undeclare :: Monoid d => Declare d a -> a
104+undeclare = runIdentity . undeclareT
105+
src/Data/Swagger/Internal/Schema.hs+230−151
@@ -2,6 +2,7 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
4{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE OverloadedLists #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
@@ -13,9 +14,12 @@
13module Data.Swagger.Internal.Schema where
14module Data.Swagger.Internal.Schema where
14
15
15import Control.Lens
16import Control.Lens
17+import Control.Monad
18+import Control.Monad.Writer
16import Data.Aeson
19import Data.Aeson
17import Data.Char
20import Data.Char
18import Data.HashMap.Strict (HashMap)
21import Data.HashMap.Strict (HashMap)
22+import qualified Data.HashMap.Strict as HashMap
19import "unordered-containers" Data.HashSet (HashSet)
23import "unordered-containers" Data.HashSet (HashSet)
20import Data.Int
24import Data.Int
21import Data.IntSet (IntSet)
25import Data.IntSet (IntSet)
@@ -31,6 +35,7 @@ import Data.Time
31import Data.Word
35import Data.Word
32import GHC.Generics
36import GHC.Generics
33
37
38+import Data.Swagger.Declare
34import Data.Swagger.Internal
39import Data.Swagger.Internal
35import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
40import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
36import Data.Swagger.Lens
41import Data.Swagger.Lens
@@ -38,42 +43,56 @@ import Data.Swagger.SchemaOptions
38
43
39-- | A @'Schema'@ with an optional name.
44-- | A @'Schema'@ with an optional name.
40-- This name can be used in references.
45-- This name can be used in references.
41−type NamedSchema = (Maybe String, Schema)
46+type NamedSchema = (Maybe T.Text, Schema)
47+
48+-- | Schema definitions, a mapping from schema name to @'Schema'@.
49+type Definitions = HashMap T.Text Schema
42
50
43unnamed :: Schema -> NamedSchema
51unnamed :: Schema -> NamedSchema
44unnamed schema = (Nothing, schema)
52unnamed schema = (Nothing, schema)
45
53
46−named :: String -> Schema -> NamedSchema
54+named :: T.Text -> Schema -> NamedSchema
47named name schema = (Just name, schema)
55named name schema = (Just name, schema)
48
56
57+plain :: Schema -> Declare Definitions NamedSchema
58+plain = pure . unnamed
59+
60+unname :: NamedSchema -> NamedSchema
61+unname (_, schema) = (Nothing, schema)
62+
63+rename :: Maybe T.Text -> NamedSchema -> NamedSchema
64+rename name (_, schema) = (name, schema)
65+
49-- | Convert a type into @'Schema'@.
66-- | Convert a type into @'Schema'@.
50--
67--
51-- An example type and instance:
68-- An example type and instance:
52--
69--
53-- @
70-- @
54-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
71-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
55−-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' as list
72+-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
56--
73--
57-- import Control.Lens
74-- import Control.Lens
58--
75--
59-- data Coord = Coord { x :: Double, y :: Double }
76-- data Coord = Coord { x :: Double, y :: Double }
60--
77--
61-- instance ToSchema Coord where
78-- instance ToSchema Coord where
62−-- toNamedSchema = (Just \"Coord\", mempty
79+-- declareNamedSchema = pure (Just \"Coord\", schema)
80+-- where
81+-- schema = mempty
63−-- & schemaType .~ SwaggerObject
82+-- & schemaType .~ SwaggerObject
64−-- & schemaProperties .~
83+-- & schemaProperties .~
65−-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
84+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))
66−-- , ("y", toSchemaRef (Proxy :: Proxy Double))
85+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))
67−-- ]
86+-- ]
68−-- & schemaRequired .~ [ "x", "y" ]
87+-- & schemaRequired .~ [ \"x\", \"y\" ]
69-- @
88-- @
70--
89--
71-- Instead of manually writing your @'ToSchema'@ instance you can
90-- Instead of manually writing your @'ToSchema'@ instance you can
72−-- use a default generic implementation of @'toNamedSchema'@.
91+-- use a default generic implementation of @'declareNamedSchema'@.
73--
92--
74-- To do that, simply add @deriving 'Generic'@ clause to your datatype
93-- To do that, simply add @deriving 'Generic'@ clause to your datatype
75-- and declare a @'ToSchema'@ instance for your datatype without
94-- and declare a @'ToSchema'@ instance for your datatype without
76−-- giving definition for @'toNamedSchema'@.
95+-- giving definition for @'declareNamedSchema'@.
77--
96--
78-- For instance, the previous example can be simplified into this:
97-- For instance, the previous example can be simplified into this:
79--
98--
@@ -87,13 +106,24 @@ named name schema = (Just name, schema)
87-- instance ToSchema Coord
106-- instance ToSchema Coord
88-- @
107-- @
89class ToSchema a where
108class ToSchema a where
90− -- | Convert a type into an optionally named schema.
109+ -- | Convert a type into an optionally named schema
110+ -- together with all used definitions.
111+ -- Note that the schema itself is included in definitions
112+ -- only if it is recursive (and thus needs its definition in scope).
91− toNamedSchema :: proxy a -> NamedSchema
113+ declareNamedSchema :: proxy a -> Declare Definitions NamedSchema
92− default toNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> NamedSchema
114+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare Definitions NamedSchema
93− toNamedSchema = genericToNamedSchema defaultSchemaOptions
115+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
116+
117+-- | Convert a type into a schema and declare all used schema definitions.
118+declareSchema :: ToSchema a => proxy a -> Declare Definitions Schema
119+declareSchema = fmap snd . declareNamedSchema
120+
121+-- | Convert a type into an optionally named schema.
122+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
123+toNamedSchema = undeclare . declareNamedSchema
94
124
95-- | Get type's schema name according to its @'ToSchema'@ instance.
125-- | Get type's schema name according to its @'ToSchema'@ instance.
96−schemaName :: ToSchema a => proxy a -> Maybe String
126+schemaName :: ToSchema a => proxy a -> Maybe T.Text
97schemaName = fst . toNamedSchema
127schemaName = fst . toNamedSchema
98
128
99-- | Convert a type into a schema.
129-- | Convert a type into a schema.
@@ -101,44 +131,67 @@ toSchema :: ToSchema a => proxy a -> Schema
101toSchema = snd . toNamedSchema
131toSchema = snd . toNamedSchema
102
132
103-- | Convert a type into a referenced schema if possible.
133-- | Convert a type into a referenced schema if possible.
104−-- Only named schemas can be references, nameless schemas are inlined.
134+-- Only named schemas can be referenced, nameless schemas are inlined.
105toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
135toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
106−toSchemaRef proxy = case toNamedSchema proxy of
136+toSchemaRef = undeclare . declareSchemaRef
107− (Just name, _) -> Ref (Reference ("#/definitions/" <> T.pack name))
108− (_, schema) -> Inline schema
109
137
110−class GToSchema (f :: * -> *) where
138+-- | Convert a type into a referenced schema if possible
111− gtoNamedSchema :: SchemaOptions -> proxy f -> Schema -> NamedSchema
139+-- and declare all used schema definitions.
140+-- Only named schemas can be referenced, nameless schemas are inlined.
141+--
142+-- Schema definitions are typically declared for every referenced schema.
143+-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
144+-- will be declared (regardless of whether it is recusive or not).
145+declareSchemaRef :: ToSchema a => proxy a -> Declare Definitions (Referenced Schema)
146+declareSchemaRef proxy = do
147+ case toNamedSchema proxy of
148+ (Just name, schema) -> do
149+ -- This check is very important as it allows generically
150+ -- derive used definitions for recursive schemas.
151+ -- Lazy Declare monad allows toNamedSchema to ignore
152+ -- any declarations (which would otherwise loop) and
153+ -- retrieve the schema and its name to check if we
154+ -- have already declared it.
155+ -- If we have, we don't need to declare anything for
156+ -- this schema this time and thus simply return the reference.
157+ known <- looks (HashMap.member name)
158+ when (not known) $ do
159+ declare [(name, schema)]
160+ void $ declareNamedSchema proxy
161+ return $ Ref (Reference ("#/definitions/" <> name))
162+ _ -> Inline <$> declareSchema proxy
112
163
113−gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema -> Schema
164+class GToSchema (f :: * -> *) where
114−gtoSchema opts proxy = snd . gtoNamedSchema opts proxy
165+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema
115
166
116instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
167instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
168+ declareNamedSchema _ = do
169+ ref <- declareSchemaRef (Proxy :: Proxy a)
117− toNamedSchema _ = unnamed $ mempty
170+ return $ unnamed $ mempty
118− & schemaType .~ SwaggerArray
171+ & schemaType .~ SwaggerArray
119− & schemaItems ?~ SchemaItemsObject (toSchemaRef (Proxy :: Proxy a))
172+ & schemaItems ?~ SchemaItemsObject ref
120−
173+
121−instance {-# OVERLAPPING #-} ToSchema String where toNamedSchema = unnamed . paramSchemaToSchema
174+instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
122−instance ToSchema Bool where toNamedSchema = unnamed . paramSchemaToSchema
175+instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
123−instance ToSchema Integer where toNamedSchema = unnamed . paramSchemaToSchema
176+instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
124−instance ToSchema Int where toNamedSchema = unnamed . paramSchemaToSchema
177+instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
125−instance ToSchema Int8 where toNamedSchema = unnamed . paramSchemaToSchema
178+instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
126−instance ToSchema Int16 where toNamedSchema = unnamed . paramSchemaToSchema
179+instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
127−instance ToSchema Int32 where toNamedSchema = unnamed . paramSchemaToSchema
180+instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
128−instance ToSchema Int64 where toNamedSchema = unnamed . paramSchemaToSchema
181+instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
129−instance ToSchema Word where toNamedSchema = unnamed . paramSchemaToSchema
182+instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
130−instance ToSchema Word8 where toNamedSchema = unnamed . paramSchemaToSchema
183+instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
131−instance ToSchema Word16 where toNamedSchema = unnamed . paramSchemaToSchema
184+instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
132−instance ToSchema Word32 where toNamedSchema = unnamed . paramSchemaToSchema
185+instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
133−instance ToSchema Word64 where toNamedSchema = unnamed . paramSchemaToSchema
186+instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
134−
187+
135−instance ToSchema Char where toNamedSchema = unnamed . paramSchemaToSchema
188+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
136−instance ToSchema Scientific where toNamedSchema = unnamed . paramSchemaToSchema
189+instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
137−instance ToSchema Double where toNamedSchema = unnamed . paramSchemaToSchema
190+instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
138−instance ToSchema Float where toNamedSchema = unnamed . paramSchemaToSchema
191+instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
139
192
140instance ToSchema a => ToSchema (Maybe a) where
193instance ToSchema a => ToSchema (Maybe a) where
141− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
194+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
142
195
143instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
196instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
144
197
@@ -150,77 +203,79 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchem
150instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
203instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
151instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
204instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
152
205
153−timeNamedSchema :: String -> String -> NamedSchema
206+timeSchema :: T.Text -> Schema
154−timeNamedSchema name format = (Just name, mempty
207+timeSchema format = mempty
155 & schemaType .~ SwaggerString
208 & schemaType .~ SwaggerString
156− & schemaFormat ?~ T.pack format
209+ & schemaFormat ?~ format
157− & schemaMinLength ?~ toInteger (length format))
210+ & schemaMinLength ?~ toInteger (T.length format)
158
211
159-- |
212-- |
160-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
213-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
161-- Just "yyyy-mm-dd"
214-- Just "yyyy-mm-dd"
162instance ToSchema Day where
215instance ToSchema Day where
163− toNamedSchema _ = timeNamedSchema "Day" "yyyy-mm-dd"
216+ declareNamedSchema _ = pure $ named "Day" (timeSchema "yyyy-mm-dd")
164
217
165-- |
218-- |
166-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
219-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
167-- Just "yyyy-mm-ddThh:MM:ss"
220-- Just "yyyy-mm-ddThh:MM:ss"
168instance ToSchema LocalTime where
221instance ToSchema LocalTime where
169− toNamedSchema _ = timeNamedSchema "LocalTime" "yyyy-mm-ddThh:MM:ss"
222+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
170
223
171-- |
224-- |
172-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
225-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
173-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
226-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
174instance ToSchema ZonedTime where
227instance ToSchema ZonedTime where
175− toNamedSchema _ = (Just "ZonedTime", mempty
176− & schemaType .~ SwaggerString
177− & schemaFormat ?~ "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
228+ declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
178− & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String)))
229+ & schemaMinLength ?~ toInteger (T.length "yyyy-mm-ddThh:MM:ssZ")
179
230
180instance ToSchema NominalDiffTime where
231instance ToSchema NominalDiffTime where
181− toNamedSchema _ = toNamedSchema (Proxy :: Proxy Integer)
232+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
182
233
183-- |
234-- |
184-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
235-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
185-- Just "yyyy-mm-ddThh:MM:ssZ"
236-- Just "yyyy-mm-ddThh:MM:ssZ"
186instance ToSchema UTCTime where
237instance ToSchema UTCTime where
187− toNamedSchema _ = timeNamedSchema "UTCTime" "yyyy-mm-ddThh:MM:ssZ"
238+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
188
239
189−instance ToSchema T.Text where toNamedSchema = unnamed . paramSchemaToSchema
240+instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
190−instance ToSchema TL.Text where toNamedSchema = unnamed . paramSchemaToSchema
241+instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
191
242
192−instance ToSchema IntSet where toNamedSchema _ = toNamedSchema (Proxy :: Proxy (Set Int))
243+instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
193
244
194-- | NOTE: This schema does not account for the uniqueness of keys.
245-- | NOTE: This schema does not account for the uniqueness of keys.
195instance ToSchema a => ToSchema (IntMap a) where
246instance ToSchema a => ToSchema (IntMap a) where
196− toNamedSchema _ = toNamedSchema (Proxy :: Proxy [(Int, a)])
247+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
197
248
198instance ToSchema a => ToSchema (Map String a) where
249instance ToSchema a => ToSchema (Map String a) where
250+ declareNamedSchema _ = do
251+ schema <- declareSchema (Proxy :: Proxy a)
199− toNamedSchema _ = unnamed $ mempty
252+ return $ unnamed $ mempty
200− & schemaType .~ SwaggerObject
253+ & schemaType .~ SwaggerObject
201− & schemaAdditionalProperties ?~ toSchema (Proxy :: Proxy a)
254+ & schemaAdditionalProperties ?~ schema
202
255
203−instance ToSchema a => ToSchema (Map T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
256+instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
204−instance ToSchema a => ToSchema (Map TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
257+instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
205
258
206−instance ToSchema a => ToSchema (HashMap String a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
259+instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
207−instance ToSchema a => ToSchema (HashMap T.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
260+instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
208−instance ToSchema a => ToSchema (HashMap TL.Text a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Map String a))
261+instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
209
262
210instance ToSchema a => ToSchema (Set a) where
263instance ToSchema a => ToSchema (Set a) where
211− toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy [a])
264+ declareNamedSchema _ = do
265+ schema <- declareSchema (Proxy :: Proxy [a])
266+ return $ unnamed $ schema
212− & schemaUniqueItems ?~ True
267+ & schemaUniqueItems ?~ True
213
268
214−instance ToSchema a => ToSchema (HashSet a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy (Set a))
269+instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
215
270
216−instance ToSchema All where toNamedSchema = unnamed . paramSchemaToSchema
271+instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
217−instance ToSchema Any where toNamedSchema = unnamed . paramSchemaToSchema
272+instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
218
273
219−instance ToSchema a => ToSchema (Sum a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
274+instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
220−instance ToSchema a => ToSchema (Product a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
275+instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
221−instance ToSchema a => ToSchema (First a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
276+instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
222−instance ToSchema a => ToSchema (Last a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
277+instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
223−instance ToSchema a => ToSchema (Dual a) where toNamedSchema _ = unnamed $ toSchema (Proxy :: Proxy a)
278+instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
224
279
225-- | Default schema for @'Bounded'@, @'Integral'@ types.
280-- | Default schema for @'Bounded'@, @'Integral'@ types.
226toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
281toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
@@ -238,19 +293,19 @@ genericToNamedSchemaBoundedIntegral opts proxy
238 = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy)
293 = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral proxy)
239
294
240-- | A configurable generic @'Schema'@ creator.
295-- | A configurable generic @'Schema'@ creator.
241−genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
296+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions Schema
242−genericToSchema opts = snd . genericToNamedSchema opts
297+genericDeclareSchema opts proxy = snd <$> genericDeclareNamedSchema opts proxy
243
298
244-- | A configurable generic @'NamedSchema'@ creator.
299-- | A configurable generic @'NamedSchema'@ creator.
245-- This function applied to @'defaultSchemaOptions'@
300-- This function applied to @'defaultSchemaOptions'@
246−-- is used as the default for @'toNamedSchema'@
301+-- is used as the default for @'declareNamedSchema'@
247-- when the type is an instance of @'Generic'@.
302-- when the type is an instance of @'Generic'@.
248−genericToNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
303+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions NamedSchema
249−genericToNamedSchema opts _ = gtoNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
304+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
250
305
251−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
306+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
252gdatatypeSchemaName opts _ = case name of
307gdatatypeSchemaName opts _ = case name of
253− (c:_) | isAlpha c && isUpper c -> Just name
308+ (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
254 _ -> Nothing
309 _ -> Nothing
255 where
310 where
256 name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
311 name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
@@ -270,75 +325,104 @@ nullarySchema = mempty
270 & schemaType .~ SwaggerArray
325 & schemaType .~ SwaggerArray
271 & schemaEnum ?~ [ toJSON () ]
326 & schemaEnum ?~ [ toJSON () ]
272
327
328+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
329+gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
330+
331+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare Definitions Schema
332+gdeclareSchema opts proxy = snd <$> gdeclareNamedSchema opts proxy mempty
333+
273instance GToSchema U1 where
334instance GToSchema U1 where
274− gtoNamedSchema _ _ _ = unnamed nullarySchema
335+ gdeclareNamedSchema _ _ _ = plain nullarySchema
275
336
276instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
337instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
277− gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f) . gtoSchema opts (Proxy :: Proxy g)
338+ gdeclareNamedSchema opts _ schema = do
339+ (_, gschema) <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
340+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
278
341
279instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
342instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
280− gtoNamedSchema opts _ s = (name, gtoSchema opts (Proxy :: Proxy f) s)
343+ gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
281 where
344 where
282 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
345 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
283
346
284instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
347instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
285− gtoNamedSchema opts _ = unnamed . gtoSchema opts (Proxy :: Proxy f)
348+ gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
286
349
287-- | Single field constructor.
350-- | Single field constructor.
288instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
351instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
289− gtoNamedSchema opts _ s
352+ gdeclareNamedSchema opts _ s
290 | unwrapUnaryRecords opts = fieldSchema
353 | unwrapUnaryRecords opts = fieldSchema
291− | otherwise =
354+ | otherwise = do
355+ (_, schema) <- recordSchema
292 case schema ^. schemaItems of
356 case schema ^. schemaItems of
293 Just (SchemaItemsArray [_]) -> fieldSchema
357 Just (SchemaItemsArray [_]) -> fieldSchema
294− _ -> unnamed schema
358+ _ -> pure (unnamed schema)
295 where
359 where
296− schema = gtoSchema opts (Proxy :: Proxy (S1 s f)) s
360+ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
297− fieldSchema = gtoNamedSchema opts (Proxy :: Proxy f) s
361+ fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
298−
362+
299−gtoSchemaRef :: GToSchema f => SchemaOptions -> proxy f -> Referenced Schema
363+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare Definitions (Referenced Schema)
364+gdeclareSchemaRef opts proxy = do
300−gtoSchemaRef opts proxy = case gtoNamedSchema opts proxy mempty of
365+ case gtoNamedSchema opts proxy of
301− (Just name, _)
366+ (Just name, schema) -> do
367+ -- This check is very important as it allows generically
368+ -- derive used definitions for recursive schemas.
369+ -- Lazy Declare monad allows toNamedSchema to ignore
370+ -- any declarations (which would otherwise loop) and
371+ -- retrieve the schema and its name to check if we
372+ -- have already declared it.
373+ -- If we have, we don't need to declare anything for
374+ -- this schema this time and thus simply return the reference.
375+ known <- looks (HashMap.member name)
376+ when (not known) $ do
377+ declare [(name, schema)]
378+ void $ gdeclareNamedSchema opts proxy mempty
302− | useReferences opts -> Ref (Reference ("#/definitions/" <> T.pack name))
379+ return $ Ref (Reference ("#/definitions/" <> name))
303− (_, schema) -> Inline schema
380+ _ -> Inline <$> gdeclareSchema opts proxy
304
381
305appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
382appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
306appendItem x Nothing = Just (SchemaItemsArray [x])
383appendItem x Nothing = Just (SchemaItemsArray [x])
307appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
384appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
308appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
385appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
309
386
310−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) => SchemaOptions -> proxy s f -> Bool -> Schema -> Schema
387+withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
388+ SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema
311−withFieldSchema opts _ isRequiredField schema
389+withFieldSchema opts _ isRequiredField schema = do
390+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
391+ return $
392+ if T.null fname
312− | T.null fieldName = schema
393+ then schema
313− & schemaType .~ SwaggerArray
394+ & schemaType .~ SwaggerArray
314− & schemaItems %~ appendItem fieldSchemaRef
395+ & schemaItems %~ appendItem ref
315− | otherwise = schema
396+ else schema
316− & schemaType .~ SwaggerObject
397+ & schemaType .~ SwaggerObject
317− & schemaProperties . at fieldName ?~ fieldSchemaRef
398+ & schemaProperties . at fname ?~ ref
318− & if isRequiredField
399+ & if isRequiredField
319− then schemaRequired %~ (fieldName :)
400+ then schemaRequired %~ (fname :)
320− else id
401+ else id
321 where
402 where
322− fieldName = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
403+ fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
323− fieldSchemaRef = gtoSchemaRef opts (Proxy :: Proxy f)
324
404
325-- | Optional record fields.
405-- | Optional record fields.
326instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
406instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
327− gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
407+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
328
408
329-- | Record fields.
409-- | Record fields.
330instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
410instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
331− gtoNamedSchema opts _ = unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
411+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
332
412
413+instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
414+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
415+
333−instance ToSchema c => GToSchema (K1 i c) where
416+instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
334− gtoNamedSchema _ _ _ = toNamedSchema (Proxy :: Proxy c)
417+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
335
418
336instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
419instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
337− gtoNamedSchema opts _ s
420+ gdeclareNamedSchema opts _ s
338− | allNullaryToStringTag opts && allNullary = unnamed (toStringTag sumSchema)
421+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
339− | otherwise = unnamed sumSchema
422+ | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
340 where
423 where
341− (All allNullary, sumSchema) = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
424+ declareSumSchema = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
425+ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
342
426
343 toStringTag schema = mempty
427 toStringTag schema = mempty
344 & schemaType .~ SwaggerString
428 & schemaType .~ SwaggerString
@@ -347,40 +431,35 @@ instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
347type AllNullary = All
431type AllNullary = All
348
432
349class GSumToSchema f where
433class GSumToSchema f where
350− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> (AllNullary, Schema)
434+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare Definitions) Schema
351
435
352instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
436instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
353− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) `after` gsumToSchema opts (Proxy :: Proxy g)
437+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
354− where
438+
355− (f `after` g) s = (a <> b, s'')
356− where
357− (a, s') = f s
358− (b, s'') = g s'
359−
360−gsumConToSchema :: forall c f proxy. Constructor c =>
439+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
361− Bool -> Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> (AllNullary, Schema)
440+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare Definitions Schema
362−gsumConToSchema isNullary tagSchemaRef opts _ schema = (All isNullary, schema
441+gsumConToSchema opts _ schema = do
442+ ref <- gdeclareSchemaRef opts (Proxy :: Proxy (C1 c f))
443+ return $ schema
363− & schemaType .~ SwaggerObject
444+ & schemaType .~ SwaggerObject
364− & schemaProperties . at tag ?~ tagSchemaRef
445+ & schemaProperties . at tag ?~ ref
365− & schemaMaxProperties ?~ 1
446+ & schemaMaxProperties ?~ 1
366− & schemaMinProperties ?~ 1)
447+ & schemaMinProperties ?~ 1
367 where
448 where
368 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
449 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
369
450
370instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
451instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
371− gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
452+ gsumToSchema opts proxy schema = do
372− where
453+ tell (All False)
373− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c f))
454+ lift $ gsumConToSchema opts proxy schema
374−
375−instance Constructor c => GSumToSchema (C1 c U1) where
376− gsumToSchema opts = gsumConToSchema True tagSchemaRef opts
377− where
378− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c U1))
379
455
380instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
456instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
381− gsumToSchema opts = gsumConToSchema False tagSchemaRef opts
457+ gsumToSchema opts proxy schema = do
382− where
458+ tell (All False)
383− tagSchemaRef = gtoSchemaRef opts (Proxy :: Proxy (C1 c (S1 s f)))
459+ lift $ gsumConToSchema opts proxy schema
460+
461+instance Constructor c => GSumToSchema (C1 c U1) where
462+ gsumToSchema opts proxy = lift . gsumConToSchema opts proxy
384
463
385data Proxy2 a b = Proxy2
464data Proxy2 a b = Proxy2
386
465
src/Data/Swagger/Lens.hs+27−4
@@ -11,38 +11,61 @@ import Data.Swagger.Internal
11import Data.Text (Text)
11import Data.Text (Text)
12
12
13-- =======================================================================
13-- =======================================================================
14−-- TH derived lenses
14+-- * TH derived lenses
15−-- =======================================================================
16
15
16+-- ** 'Swagger' lenses
17makeLenses ''Swagger
17makeLenses ''Swagger
18+-- ** 'Host' lenses
18makeLenses ''Host
19makeLenses ''Host
20+-- ** 'Info' lenses
19makeLenses ''Info
21makeLenses ''Info
22+-- ** 'Contact' lenses
20makeLenses ''Contact
23makeLenses ''Contact
24+-- ** 'License' lenses
21makeLenses ''License
25makeLenses ''License
26+-- ** 'Paths' lenses
22makeLenses ''Paths
27makeLenses ''Paths
28+-- ** 'PathItem' lenses
23makeLenses ''PathItem
29makeLenses ''PathItem
30+-- ** 'Tag' lenses
24makeLenses ''Tag
31makeLenses ''Tag
32+-- ** 'Operation' lenses
25makeLenses ''Operation
33makeLenses ''Operation
34+-- ** 'Param' lenses
26makeLenses ''Param
35makeLenses ''Param
36+-- ** 'ParamAnySchema' prisms
27makePrisms ''ParamAnySchema
37makePrisms ''ParamAnySchema
38+-- ** 'ParamOtherSchema' lenses
28makeLenses ''ParamOtherSchema
39makeLenses ''ParamOtherSchema
40+-- ** 'Items' lenses
29makeLenses ''Items
41makeLenses ''Items
42+-- ** 'Header' lenses
30makeLenses ''Header
43makeLenses ''Header
44+-- ** 'Schema' lenses
31makeLenses ''Schema
45makeLenses ''Schema
46+-- ** 'SchemaItems' prisms
32makePrisms ''SchemaItems
47makePrisms ''SchemaItems
48+-- ** 'ParamSchema' lenses
33makeLenses ''ParamSchema
49makeLenses ''ParamSchema
50+-- ** 'Xml' lenses
34makeLenses ''Xml
51makeLenses ''Xml
52+-- ** 'Responses' lenses
35makeLenses ''Responses
53makeLenses ''Responses
54+-- ** 'Response' lenses
36makeLenses ''Response
55makeLenses ''Response
56+-- ** 'SecurityScheme' lenses
37makeLenses ''SecurityScheme
57makeLenses ''SecurityScheme
58+-- ** 'SecuritySchemeType' prisms
38makePrisms ''SecuritySchemeType
59makePrisms ''SecuritySchemeType
60+-- ** 'ApiKeyParams' lenses
39makeLenses ''ApiKeyParams
61makeLenses ''ApiKeyParams
62+-- ** 'OAuth2Params' lenses
40makeLenses ''OAuth2Params
63makeLenses ''OAuth2Params
64+-- ** 'ExternalDocs' lenses
41makeLenses ''ExternalDocs
65makeLenses ''ExternalDocs
42
66
43-- =======================================================================
67-- =======================================================================
44−-- Helper classy lenses
68+-- * Helper classy lenses
45−-- =======================================================================
46
69
47class HasDescription s d | s -> d where
70class HasDescription s d | s -> d where
48 description :: Lens' s d
71 description :: Lens' s d
src/Data/Swagger/Schema.hs+5−2
@@ -9,14 +9,17 @@
9module Data.Swagger.Schema (
9module Data.Swagger.Schema (
10 -- * Encoding
10 -- * Encoding
11 ToSchema(..),
11 ToSchema(..),
12+ Definitions,
12 NamedSchema,
13 NamedSchema,
14+ declareSchema,
15+ declareSchemaRef,
13 toSchema,
16 toSchema,
14 toSchemaRef,
17 toSchemaRef,
15 schemaName,
18 schemaName,
16
19
17 -- * Generic schema encoding
20 -- * Generic schema encoding
18− genericToSchema,
21+ genericDeclareNamedSchema,
19− genericToNamedSchema,
22+ genericDeclareSchema,
20 genericToNamedSchemaBoundedIntegral,
23 genericToNamedSchemaBoundedIntegral,
21 toSchemaBoundedIntegral,
24 toSchemaBoundedIntegral,
22 paramSchemaToNamedSchema,
25 paramSchemaToNamedSchema,
swagger2.cabal+2
@@ -20,6 +20,7 @@ library
20 hs-source-dirs: src
20 hs-source-dirs: src
21 exposed-modules:
21 exposed-modules:
22 Data.Swagger
22 Data.Swagger
23+ Data.Swagger.Declare
23 Data.Swagger.Lens
24 Data.Swagger.Lens
24 Data.Swagger.ParamSchema
25 Data.Swagger.ParamSchema
25 Data.Swagger.Schema
26 Data.Swagger.Schema
@@ -35,6 +36,7 @@ library
35 , containers
36 , containers
36 , hashable
37 , hashable
37 , http-media
38 , http-media
39+ , mtl
38 , network
40 , network
39 , template-haskell
41 , template-haskell
40 , text
42 , text
test/Data/Swagger/SchemaSpec.hs+29−8
@@ -8,11 +8,16 @@ module Data.Swagger.SchemaSpec where
8import Data.Aeson
8import Data.Aeson
9import Data.Aeson.QQ
9import Data.Aeson.QQ
10import Data.Char
10import Data.Char
11+import qualified Data.HashMap.Strict as HashMap
11import Data.Proxy
12import Data.Proxy
12import Data.Set (Set)
13import Data.Set (Set)
14+import qualified Data.Set as Set
15+import Data.Text (Text)
16+import qualified Data.Text as Text
13import GHC.Generics
17import GHC.Generics
14
18
15import Data.Swagger
19import Data.Swagger
20+import Data.Swagger.Declare
16
21
17import SpecCommon
22import SpecCommon
18import Test.Hspec
23import Test.Hspec
@@ -23,7 +28,14 @@ checkToSchema proxy js = toSchema proxy <~> js
23checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
28checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
24checkSchemaName sname proxy =
29checkSchemaName sname proxy =
25 it ("schema name is " ++ show sname) $
30 it ("schema name is " ++ show sname) $
26− schemaName proxy `shouldBe` sname
31+ schemaName proxy `shouldBe` fmap Text.pack sname
32+
33+checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
34+checkDefs proxy names =
35+ it ("uses these definitions " ++ show names) $
36+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
37+ where
38+ defs = execDeclare (declareNamedSchema proxy) mempty
27
39
28spec :: Spec
40spec :: Spec
29spec = do
41spec = do
@@ -51,6 +63,13 @@ spec = do
51 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
63 context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
52 context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
64 context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
53 context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
65 context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
66+ describe "Generic Definitions" $ do
67+ context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
68+ context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
69+ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
70+ context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
71+ context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
72+ context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
54
73
55main :: IO ()
74main :: IO ()
56main = hspec spec
75main = hspec spec
@@ -105,7 +124,7 @@ data Point = Point
105 } deriving (Generic)
124 } deriving (Generic)
106
125
107instance ToSchema Point where
126instance ToSchema Point where
108− toNamedSchema = genericToNamedSchema defaultSchemaOptions
127+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
109 { fieldLabelModifier = map toLower . drop (length "point") }
128 { fieldLabelModifier = map toLower . drop (length "point") }
110
129
111pointSchemaJSON :: Value
130pointSchemaJSON :: Value
@@ -145,7 +164,7 @@ colorSchemaJSON = [aesonQQ|
145
164
146data Shade = Dim | Bright deriving (Generic, ToParamSchema)
165data Shade = Dim | Bright deriving (Generic, ToParamSchema)
147
166
148−instance ToSchema Shade where toNamedSchema = paramSchemaToNamedSchema defaultSchemaOptions
167+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
149
168
150shadeSchemaJSON :: Value
169shadeSchemaJSON :: Value
151shadeSchemaJSON = [aesonQQ|
170shadeSchemaJSON = [aesonQQ|
@@ -185,7 +204,7 @@ newtype Email = Email { getEmail :: String }
185 deriving (Generic)
204 deriving (Generic)
186
205
187instance ToSchema Email where
206instance ToSchema Email where
188− toNamedSchema = genericToNamedSchema defaultSchemaOptions
207+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
189 { unwrapUnaryRecords = True }
208 { unwrapUnaryRecords = True }
190
209
191emailSchemaJSON :: Value
210emailSchemaJSON :: Value
@@ -258,7 +277,7 @@ data MyRoseTree = MyRoseTree
258 } deriving (Generic)
277 } deriving (Generic)
259
278
260instance ToSchema MyRoseTree where
279instance ToSchema MyRoseTree where
261− toNamedSchema = genericToNamedSchema defaultSchemaOptions
280+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
262 { datatypeNameModifier = drop (length "My") }
281 { datatypeNameModifier = drop (length "My") }
263
282
264myRoseTreeSchemaJSON :: Value
283myRoseTreeSchemaJSON :: Value
@@ -288,7 +307,9 @@ myRoseTreeSchemaJSON = [aesonQQ|
288newtype Inlined a = Inlined { getInlined :: a }
307newtype Inlined a = Inlined { getInlined :: a }
289
308
290instance ToSchema a => ToSchema (Inlined a) where
309instance ToSchema a => ToSchema (Inlined a) where
291− toNamedSchema _ = (Nothing, toSchema (Proxy :: Proxy a))
310+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
311+ where
312+ unname (_, schema) = (Nothing, schema)
292
313
293newtype Players = Players [Inlined Player]
314newtype Players = Players [Inlined Player]
294 deriving (Generic, ToSchema)
315 deriving (Generic, ToSchema)
@@ -322,7 +343,7 @@ data Status
322 deriving (Generic)
343 deriving (Generic)
323
344
324instance ToSchema Status where
345instance ToSchema Status where
325− toNamedSchema = genericToNamedSchema defaultSchemaOptions
346+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
326 { constructorTagModifier = map toLower . drop (length "Status") }
347 { constructorTagModifier = map toLower . drop (length "Status") }
327
348
328statusSchemaJSON :: Value
349statusSchemaJSON :: Value
@@ -397,7 +418,7 @@ data Light
397 deriving (Generic)
418 deriving (Generic)
398
419
399instance ToSchema Light where
420instance ToSchema Light where
400− toNamedSchema = genericToNamedSchema defaultSchemaOptions
421+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
401 { unwrapUnaryRecords = True }
422 { unwrapUnaryRecords = True }
402
423
403lightSchemaJSON :: Value
424lightSchemaJSON :: Value