Merge branch 'master' into identity-instances

src/Data/Swagger.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 -- |
 -- Module:      Data.Swagger
 -- Maintainer:  Nickolay Kudasov <nickolay@getshoptv.com>
@@ -286,13 +287,46 @@ import Data.Swagger.Internal
 -- >>> instance ToSchema SampleSumType
 -- >>> instance ToJSON SampleSumType
 --
--- we can not derive a valid schema for a mix of the above. The following will result in a bad schema
--- 
+-- we can not derive a valid schema for a mix of the above. The following will result in a type error
+--
+#if __GLASGOW_HASKELL__ < 800
 -- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
 -- >>> instance ToSchema BadMixedType
--- >>> instance ToJSON BadMixedType
+-- ...
+-- ... error:
+-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType
+-- ...                      BadMixedType)
+-- ...     arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’
+-- ... • In the expression:
+-- ...     Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
+-- ...   In an equation for ‘declareNamedSchema’:
+-- ...       declareNamedSchema
+-- ...         = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
+-- ...   In the instance declaration for ‘ToSchema BadMixedType’
+#else
+-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
+-- >>> instance ToSchema BadMixedType
+-- ...
+-- ... error:
+-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
+-- ...   BadMixedType is a mixed sum type (has both unit and non-unit constructors).
+-- ...   Swagger does not have a good representation for these types.
+-- ...   Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
+-- ...   that matches aeson's Generic-based toJSON,
+-- ...   but that's not supported by some Swagger tools.
+-- ... • In the expression:
+-- ...     Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
+-- ...   In an equation for ‘declareNamedSchema’:
+-- ...       declareNamedSchema
+-- ...         = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
+-- ...   In the instance declaration for ‘ToSchema BadMixedType’
+#endif
+--
+-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
 --
--- This is due to the fact that @'ToJSON'@ encodes empty constructors with an empty list which can not be described in a swagger schema.
+-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
+-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
+-- >>> instance ToJSON BadMixedType
 --
 
 -- $manipulation

src/Data/Swagger/Internal/Schema.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -64,6 +65,7 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
 import Data.Swagger.Lens hiding (name, schema)
 import qualified Data.Swagger.Lens as Swagger
 import Data.Swagger.SchemaOptions
+import Data.Swagger.Internal.TypeShape
 
 #if __GLASGOW_HASKELL__ < 800
 #else
@@ -137,7 +139,8 @@ class ToSchema a where
   -- Note that the schema itself is included in definitions
   -- only if it is recursive (and thus needs its definition in scope).
   declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
-  default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
+  default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
+    proxy a -> Declare (Definitions Schema) NamedSchema
   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
 
 -- | Convert a type into a schema and declare all used schema definitions.
@@ -583,15 +586,32 @@ genericToNamedSchemaBoundedIntegral opts proxy
   = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
 
 -- | A configurable generic @'Schema'@ creator.
-genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
-genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
+  SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
+genericDeclareSchema = genericDeclareSchemaUnrestricted
 
 -- | A configurable generic @'NamedSchema'@ creator.
 -- This function applied to @'defaultSchemaOptions'@
 -- is used as the default for @'declareNamedSchema'@
 -- when the type is an instance of @'Generic'@.
-genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
-genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
+  SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
+
+-- | A configurable generic @'Schema'@ creator.
+--
+-- Unlike 'genericDeclareSchema' also works for mixed sum types.
+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
+genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
+
+-- | A configurable generic @'NamedSchema'@ creator.
+--
+-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
+genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) =>
+  SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
 
 gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
 gdatatypeSchemaName opts _ = case name of
@@ -710,7 +730,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
 instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
 
-instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
+instance ( GSumToSchema f
+         , GSumToSchema g
+         ) => GToSchema (f :+: g)
+   where
   gdeclareNamedSchema = gdeclareNamedSumSchema
 
 gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

src/Data/Swagger/Internal/TypeShape.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Data.Swagger.Internal.TypeShape where
+
+import Data.Proxy
+import GHC.Generics
+import GHC.TypeLits
+import GHC.Exts (Constraint)
+
+-- | Shape of a datatype.
+data TypeShape
+  = Enumeration     -- ^ A simple enumeration.
+  | SumOfProducts   -- ^ A product or a sum of non-unit products.
+  | Mixed           -- ^ Mixed sum type with both unit and non-unit constructors.
+
+-- | A combined shape for a product type.
+type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
+  ProdCombine Mixed b     = Mixed   -- technically this cannot happen since Haskell types are sums of products
+  ProdCombine a     Mixed = Mixed   -- technically this cannot happen since Haskell types are sums of products
+  ProdCombine a     b     = SumOfProducts
+
+-- | A combined shape for a sum type.
+type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
+  SumCombine Enumeration   Enumeration   = Enumeration
+  SumCombine SumOfProducts SumOfProducts = SumOfProducts
+  SumCombine a b = Mixed
+
+type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
+  TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
+
+type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
+  GenericHasSimpleShape t f Enumeration   = ()
+  GenericHasSimpleShape t f SumOfProducts = ()
+#if __GLASGOW_HASKELL__ < 800
+  GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
+
+class CannotDeriveSchemaForMixedSumType t where
+#else
+  GenericHasSimpleShape t f Mixed =
+    TypeError
+      (     Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
+      :$$:  ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
+      :$$:  Text "Swagger does not have a good representation for these types."
+      :$$:  Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
+      :$$:  Text "that matches aeson's Generic-based toJSON,"
+      :$$:  Text "but that's not supported by some Swagger tools."
+      )
+#endif
+
+-- | Infer a 'TypeShape' for a generic representation of a type.
+type family GenericShape (g :: * -> *) :: TypeShape
+
+type instance GenericShape (f :*: g)        = ProdCombine  (GenericShape f) (GenericShape g)
+type instance GenericShape (f :+: g)        = SumCombine   (GenericShape f) (GenericShape g)
+type instance GenericShape (D1  d f)        = GenericShape f
+type instance GenericShape (C1 c U1)        = Enumeration
+type instance GenericShape (C1 c (S1 s f))  = SumOfProducts
+type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
+
+

src/Data/Swagger/Schema.hs

@@ -22,6 +22,10 @@ module Data.Swagger.Schema (
   paramSchemaToNamedSchema,
   paramSchemaToSchema,
 
+  -- ** Unrestricted versions
+  genericDeclareNamedSchemaUnrestricted,
+  genericDeclareSchemaUnrestricted,
+
   -- * Schema templates
   passwordSchema,
   binarySchema,

swagger2.cabal

@@ -47,6 +47,7 @@ library
     Data.Swagger.Internal.ParamSchema
     Data.Swagger.Internal.Utils
     Data.Swagger.Internal.AesonUtils
+    Data.Swagger.Internal.TypeShape
   build-depends:       base        >=4.7   && <4.11
                      , base-compat >=0.9.1 && <0.10
                      , aeson       >=0.11.2.1

test/Data/Swagger/Schema/ValidationSpec.hs

@@ -148,7 +148,8 @@ instance Arbitrary MyRoseTree where
 
 data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
 
-instance ToSchema Light
+instance ToSchema Light where
+  declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
 
 instance ToJSON Light where
   toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

test/Data/Swagger/SchemaSpec.hs

@@ -599,7 +599,7 @@ data Light
   deriving (Generic)
 
 instance ToSchema Light where
-  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
+  declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
     { unwrapUnaryRecords = True }
 
 lightSchemaJSON :: Value