git.iko.soy/typeable/swagger2
on master help sign in
Merge pull request #118 from GetShopTV/vwwv-constraint-derived-shapes

Type error by default on mixed sum types

commit47e7fdf02ef6b62e6cfc631535da857d1f171787 authorNickolay Kudasov <fizruk@users.noreply.github.com> dateFri 8 Sep 2017, 19:11 (9 years ago) parent7b86c90b6baa31
7 files changed+141−12
compare with master
unifiedsplit
src/Data/Swagger.hs+38−4 src/Data/Swagger/Internal/Schema.hs+29−6 src/Data/Swagger/Internal/TypeShape.hs+66 src/Data/Swagger/Schema.hs+4 swagger2.cabal+1 test/Data/Swagger/Schema/ValidationSpec.hs+2−1 test/Data/Swagger/SchemaSpec.hs+1−1
src/Data/Swagger.hs+38−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12-- |
23-- Module: Data.Swagger
34-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -286,13 +287,46 @@ import Data.Swagger.Internal
286287-- >>> instance ToSchema SampleSumType
287288-- >>> instance ToJSON SampleSumType
288289--
289−-- we can not derive a valid schema for a mix of the above. The following will result in a bad schema
290−--
290+-- we can not derive a valid schema for a mix of the above. The following will result in a type error
291+--
292+#if __GLASGOW_HASKELL__ < 800
291293-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
292294-- >>> 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':
294326--
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
296330--
297331
298332-- $manipulation
src/Data/Swagger/Internal/Schema.hs+29−6
@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE DefaultSignatures #-}
34{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE FlexibleInstances #-}
@@ -64,6 +65,7 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
6465import Data.Swagger.Lens hiding (name, schema)
6566import qualified Data.Swagger.Lens as Swagger
6667import Data.Swagger.SchemaOptions
68+import Data.Swagger.Internal.TypeShape
6769
6870#if __GLASGOW_HASKELL__ < 800
6971#else
@@ -137,7 +139,8 @@ class ToSchema a where
137139 -- Note that the schema itself is included in definitions
138140 -- only if it is recursive (and thus needs its definition in scope).
139141 declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
140− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
142+ default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
143+ proxy a -> Declare (Definitions Schema) NamedSchema
141144 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
142145
143146-- | Convert a type into a schema and declare all used schema definitions.
@@ -581,15 +584,32 @@ genericToNamedSchemaBoundedIntegral opts proxy
581584 = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
582585
583586-- | A configurable generic @'Schema'@ creator.
584−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
585−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
587+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
588+ SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
589+genericDeclareSchema = genericDeclareSchemaUnrestricted
586590
587591-- | A configurable generic @'NamedSchema'@ creator.
588592-- This function applied to @'defaultSchemaOptions'@
589593-- is used as the default for @'declareNamedSchema'@
590594-- 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
592−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
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
612+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
593613
594614gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
595615gdatatypeSchemaName opts _ = case name of
@@ -708,7 +728,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
708728instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
709729 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
710730
711−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
731+instance ( GSumToSchema f
732+ , GSumToSchema g
733+ ) => GToSchema (f :+: g)
734+ where
712735 gdeclareNamedSchema = gdeclareNamedSumSchema
713736
714737gdeclareNamedSumSchema :: 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 (
2222 paramSchemaToNamedSchema,
2323 paramSchemaToSchema,
2424
25+ -- ** Unrestricted versions
26+ genericDeclareNamedSchemaUnrestricted,
27+ genericDeclareSchemaUnrestricted,
28+
2529 -- * Schema templates
2630 passwordSchema,
2731 binarySchema,
swagger2.cabal+1
@@ -47,6 +47,7 @@ library
4747 Data.Swagger.Internal.ParamSchema
4848 Data.Swagger.Internal.Utils
4949 Data.Swagger.Internal.AesonUtils
50+ Data.Swagger.Internal.TypeShape
5051 build-depends: base >=4.7 && <4.11
5152 , base-compat >=0.9.1 && <0.10
5253 , aeson >=0.11.2.1
test/Data/Swagger/Schema/ValidationSpec.hs+2−1
@@ -148,7 +148,8 @@ instance Arbitrary MyRoseTree where
148148
149149data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
150150
151−instance ToSchema Light
151+instance ToSchema Light where
152+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
152153
153154instance ToJSON Light where
154155 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
test/Data/Swagger/SchemaSpec.hs+1−1
@@ -599,7 +599,7 @@ data Light
599599 deriving (Generic)
600600
601601instance ToSchema Light where
602− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
602+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
603603 { unwrapUnaryRecords = True }
604604
605605lightSchemaJSON :: Value