git.iko.soy/typeable/openapi3
on master help sign in
Merge pull request #118 from GetShopTV/vwwv-constraint-derived-shapes
47e7fdfNickolay Kudasov
src/Data/Swagger.hs+38−4
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1-- |
2-- |
2-- Module: Data.Swagger
3-- Module: Data.Swagger
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -286,13 +287,46 @@ import Data.Swagger.Internal
286-- >>> instance ToSchema SampleSumType
287-- >>> instance ToSchema SampleSumType
287-- >>> instance ToJSON SampleSumType
288-- >>> instance ToJSON SampleSumType
288--
289--
289−-- we can not derive a valid schema for a mix of the above. The following will result in a bad schema
290+-- we can not derive a valid schema for a mix of the above. The following will result in a type error
290−--
291+--
292+#if __GLASGOW_HASKELL__ < 800
291-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
293-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
292-- >>> instance ToSchema BadMixedType
294-- >>> instance ToSchema BadMixedType
293−-- >>> instance ToJSON BadMixedType
295+-- ...
296+-- ... error:
297+-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType
298+-- ... BadMixedType)
299+-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’
300+-- ... • In the expression:
301+-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
302+-- ... In an equation for ‘declareNamedSchema’:
303+-- ... declareNamedSchema
304+-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
305+-- ... In the instance declaration for ‘ToSchema BadMixedType’
306+#else
307+-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
308+-- >>> instance ToSchema BadMixedType
309+-- ...
310+-- ... error:
311+-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
312+-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).
313+-- ... Swagger does not have a good representation for these types.
314+-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
315+-- ... that matches aeson's Generic-based toJSON,
316+-- ... but that's not supported by some Swagger tools.
317+-- ... • In the expression:
318+-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
319+-- ... In an equation for ‘declareNamedSchema’:
320+-- ... declareNamedSchema
321+-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
322+-- ... In the instance declaration for ‘ToSchema BadMixedType’
323+#endif
324+--
325+-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
294--
326--
295−-- This is due to the fact that @'ToJSON'@ encodes empty constructors with an empty list which can not be described in a swagger schema.
327+-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
328+-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
329+-- >>> instance ToJSON BadMixedType
296--
330--
297
331
298-- $manipulation
332-- $manipulation
src/Data/Swagger/Internal/Schema.hs+29−6
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
@@ -64,6 +65,7 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
64import Data.Swagger.Lens hiding (name, schema)
65import Data.Swagger.Lens hiding (name, schema)
65import qualified Data.Swagger.Lens as Swagger
66import qualified Data.Swagger.Lens as Swagger
66import Data.Swagger.SchemaOptions
67import Data.Swagger.SchemaOptions
68+import Data.Swagger.Internal.TypeShape
67
69
68#if __GLASGOW_HASKELL__ < 800
70#if __GLASGOW_HASKELL__ < 800
69#else
71#else
@@ -137,7 +139,8 @@ class ToSchema a where
137 -- Note that the schema itself is included in definitions
139 -- Note that the schema itself is included in definitions
138 -- only if it is recursive (and thus needs its definition in scope).
140 -- only if it is recursive (and thus needs its definition in scope).
139 declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
141 declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
142+ default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
140− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
143+ proxy a -> Declare (Definitions Schema) NamedSchema
141 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
144 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
142
145
143-- | Convert a type into a schema and declare all used schema definitions.
146-- | Convert a type into a schema and declare all used schema definitions.
@@ -581,15 +584,32 @@ genericToNamedSchemaBoundedIntegral opts proxy
581 = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
584 = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
582
585
583-- | A configurable generic @'Schema'@ creator.
586-- | A configurable generic @'Schema'@ creator.
587+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
584−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
588+ SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
585−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
589+genericDeclareSchema = genericDeclareSchemaUnrestricted
586
590
587-- | A configurable generic @'NamedSchema'@ creator.
591-- | A configurable generic @'NamedSchema'@ creator.
588-- This function applied to @'defaultSchemaOptions'@
592-- This function applied to @'defaultSchemaOptions'@
589-- is used as the default for @'declareNamedSchema'@
593-- is used as the default for @'declareNamedSchema'@
590-- when the type is an instance of @'Generic'@.
594-- when the type is an instance of @'Generic'@.
591−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
595+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
596+ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
597+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
598+
599+-- | A configurable generic @'Schema'@ creator.
600+--
601+-- Unlike 'genericDeclareSchema' also works for mixed sum types.
602+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
603+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
604+genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
605+
606+-- | A configurable generic @'NamedSchema'@ creator.
607+--
608+-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
609+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
610+genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) =>
611+ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
592−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
612+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
593
613
594gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
614gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
595gdatatypeSchemaName opts _ = case name of
615gdatatypeSchemaName opts _ = case name of
@@ -708,7 +728,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
708instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
728instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
709 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
729 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
710
730
711−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
731+instance ( GSumToSchema f
732+ , GSumToSchema g
733+ ) => GToSchema (f :+: g)
734+ where
712 gdeclareNamedSchema = gdeclareNamedSumSchema
735 gdeclareNamedSchema = gdeclareNamedSumSchema
713
736
714gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
737gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
src/Data/Swagger/Internal/TypeShape.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+
9+module Data.Swagger.Internal.TypeShape where
10+
11+import Data.Proxy
12+import GHC.Generics
13+import GHC.TypeLits
14+import GHC.Exts (Constraint)
15+
16+-- | Shape of a datatype.
17+data TypeShape
18+ = Enumeration -- ^ A simple enumeration.
19+ | SumOfProducts -- ^ A product or a sum of non-unit products.
20+ | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
21+
22+-- | A combined shape for a product type.
23+type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
24+ ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
25+ ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
26+ ProdCombine a b = SumOfProducts
27+
28+-- | A combined shape for a sum type.
29+type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
30+ SumCombine Enumeration Enumeration = Enumeration
31+ SumCombine SumOfProducts SumOfProducts = SumOfProducts
32+ SumCombine a b = Mixed
33+
34+type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
35+ TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
36+
37+type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
38+ GenericHasSimpleShape t f Enumeration = ()
39+ GenericHasSimpleShape t f SumOfProducts = ()
40+#if __GLASGOW_HASKELL__ < 800
41+ GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
42+
43+class CannotDeriveSchemaForMixedSumType t where
44+#else
45+ GenericHasSimpleShape t f Mixed =
46+ TypeError
47+ ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
48+ :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
49+ :$$: Text "Swagger does not have a good representation for these types."
50+ :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
51+ :$$: Text "that matches aeson's Generic-based toJSON,"
52+ :$$: Text "but that's not supported by some Swagger tools."
53+ )
54+#endif
55+
56+-- | Infer a 'TypeShape' for a generic representation of a type.
57+type family GenericShape (g :: * -> *) :: TypeShape
58+
59+type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
60+type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
61+type instance GenericShape (D1 d f) = GenericShape f
62+type instance GenericShape (C1 c U1) = Enumeration
63+type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
64+type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
65+
66+
src/Data/Swagger/Schema.hs+4
@@ -22,6 +22,10 @@ module Data.Swagger.Schema (
22 paramSchemaToNamedSchema,
22 paramSchemaToNamedSchema,
23 paramSchemaToSchema,
23 paramSchemaToSchema,
24
24
25+ -- ** Unrestricted versions
26+ genericDeclareNamedSchemaUnrestricted,
27+ genericDeclareSchemaUnrestricted,
28+
25 -- * Schema templates
29 -- * Schema templates
26 passwordSchema,
30 passwordSchema,
27 binarySchema,
31 binarySchema,
swagger2.cabal+1
@@ -47,6 +47,7 @@ library
47 Data.Swagger.Internal.ParamSchema
47 Data.Swagger.Internal.ParamSchema
48 Data.Swagger.Internal.Utils
48 Data.Swagger.Internal.Utils
49 Data.Swagger.Internal.AesonUtils
49 Data.Swagger.Internal.AesonUtils
50+ Data.Swagger.Internal.TypeShape
50 build-depends: base >=4.7 && <4.11
51 build-depends: base >=4.7 && <4.11
51 , base-compat >=0.9.1 && <0.10
52 , base-compat >=0.9.1 && <0.10
52 , aeson >=0.11.2.1
53 , aeson >=0.11.2.1
test/Data/Swagger/Schema/ValidationSpec.hs+2−1
@@ -148,7 +148,8 @@ instance Arbitrary MyRoseTree where
148
148
149data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
149data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
150
150
151−instance ToSchema Light
151+instance ToSchema Light where
152+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
152
153
153instance ToJSON Light where
154instance ToJSON Light where
154 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
155 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
test/Data/Swagger/SchemaSpec.hs+1−1
@@ -599,7 +599,7 @@ data Light
599 deriving (Generic)
599 deriving (Generic)
600
600
601instance ToSchema Light where
601instance ToSchema Light where
602− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
602+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
603 { unwrapUnaryRecords = True }
603 { unwrapUnaryRecords = True }
604
604
605lightSchemaJSON :: Value
605lightSchemaJSON :: Value