a4bab47 · typeable/openapi3

git.iko.soy/typeable/openapi3

on master help sign in

Improve type shape restrictions

a4bab47Nickolay Kudasov9 years ago

src/Data/Swagger/Internal/Schema.hs+24−8

compare with master

unifiedsplit

@@ -138,7 +138,8 @@ class ToSchema a where

138 -- Note that the schema itself is included in definitions

139 -- only if it is recursive (and thus needs its definition in scope).

140 declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema

141+ default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

141− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema

142+ proxy a -> Declare (Definitions Schema) NamedSchema

142 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

143 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

143

144

144-- | Convert a type into a schema and declare all used schema definitions.

145-- | Convert a type into a schema and declare all used schema definitions.

@@ -582,15 +583,32 @@ genericToNamedSchemaBoundedIntegral opts proxy

582 = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)

583 = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)

583

584

584-- | A configurable generic @'Schema'@ creator.

585-- | A configurable generic @'Schema'@ creator.

586+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>

585−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema

587+ SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema

586−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy

588+genericDeclareSchema = genericDeclareSchemaUnrestricted

587

589

588-- | A configurable generic @'NamedSchema'@ creator.

590-- | A configurable generic @'NamedSchema'@ creator.

589-- This function applied to @'defaultSchemaOptions'@

591-- This function applied to @'defaultSchemaOptions'@

590-- is used as the default for @'declareNamedSchema'@

592-- is used as the default for @'declareNamedSchema'@

591-- when the type is an instance of @'Generic'@.

593-- when the type is an instance of @'Generic'@.

592−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

594+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

595+ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

596+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

597+

598+-- | A configurable generic @'Schema'@ creator.

599+--

600+-- Unlike 'genericDeclareSchema' also works for mixed sum types.

601+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

602+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema

603+genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

604+

605+-- | A configurable generic @'NamedSchema'@ creator.

606+--

607+-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.

608+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

609+genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) =>

610+ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

593−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

611+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

594

612

595gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

613gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

596gdatatypeSchemaName opts _ = case name of

614gdatatypeSchemaName opts _ = case name of

@@ -711,9 +729,7 @@ instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where

711

729

712instance ( GSumToSchema f

730instance ( GSumToSchema f

713 , GSumToSchema g

731 , GSumToSchema g

714− , LegalShape (GenericShape (f :+: g))

715−

716− ) => GToSchema (f :+: g)

732+ ) => GToSchema (f :+: g)

717 where

733 where

718 gdeclareNamedSchema = gdeclareNamedSumSchema

734 gdeclareNamedSchema = gdeclareNamedSumSchema

719

735

src/Data/Swagger/Internal/TypeShape.hs+47−48

@@ -1,60 +1,59 @@

1−

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE KindSignatures #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE UndecidableInstances #-}

6+{-# LANGUAGE UndecidableInstances #-}

7−

9module Data.Swagger.Internal.TypeShape where

8module Data.Swagger.Internal.TypeShape where

11−

12import Data.Proxy

10import Data.Proxy

13import GHC.Generics

11import GHC.Generics

14import GHC.TypeLits

12import GHC.TypeLits

15−

13+import GHC.Exts (Constraint)

14+

15+-- | Shape of a datatype.

16−data TypeShape = EnumShape

16+data TypeShape

17− | NestedShape

17+ = Enumeration -- ^ A simple enumeration.

18− | IlegalShape

18+ | SumOfProducts -- ^ A product or a sum of non-unit products.

19−

19+ | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.

20−

20+

21+-- | A combined shape for a product type.

21−type family ProdCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where

22+type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

22−

23+ ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products

23− ProdCombine IlegalShape b = IlegalShape

24+ ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products

24− ProdCombine a IlegalShape = IlegalShape

25− ProdCombine a b = NestedShape

25+ ProdCombine a b = SumOfProducts

26−

26+

27−

27+-- | A combined shape for a sum type.

28−type family SumCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where

28+type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

29−

29+ SumCombine Enumeration Enumeration = Enumeration

30− SumCombine EnumShape EnumShape = EnumShape

30+ SumCombine SumOfProducts SumOfProducts = SumOfProducts

31− SumCombine NestedShape NestedShape = NestedShape

32− SumCombine a b = IlegalShape

31+ SumCombine a b = Mixed

33−

32+

34−

33+type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where

35−

34+ TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))

36−

35+

37−class LegalShape (a :: TypeShape) where

36+type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where

38−

37+ GenericHasSimpleShape t f Enumeration = ()

39−instance LegalShape EnumShape

38+ GenericHasSimpleShape t f SumOfProducts = ()

40−instance LegalShape NestedShape

39+ GenericHasSimpleShape t f Mixed =

41−

42−instance TypeError

40+ TypeError

43− ( Text "Cannot auto derive swagger class, for that to be possible, make sure that any constructor "

41+ ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t

44− :$$: Text "for this type, only holds 0 arguments if there are no other contructors with more than 0 arguments,"

42+ :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."

45− :$$: Text "otherwise, every constructor have to hold at least 1 argument"

43+ :$$: Text "Swagger does not have a good representation for these types."

46− ) => LegalShape IlegalShape

44+ :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"

47−

45+ :$$: Text "that matches aeson's Generic-based toJSON,"

48−

46+ :$$: Text "but that's not supported by some Swagger tools."

49−

47+ )

48+

49+-- | Infer a 'TypeShape' for a generic representation of a type.

50−type family GenericShape ( g :: * -> * ) :: TypeShape

50+type family GenericShape (g :: * -> *) :: TypeShape

51−

53type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)

52type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)

54type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)

53type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)

55type instance GenericShape (D1 d f) = GenericShape f

54type instance GenericShape (D1 d f) = GenericShape f

56−type instance GenericShape (C1 c U1) = EnumShape

55+type instance GenericShape (C1 c U1) = Enumeration

57−type instance GenericShape (C1 c (S1 s f)) = NestedShape

56+type instance GenericShape (C1 c (S1 s f)) = SumOfProducts

58−type instance GenericShape (C1 c (f :*: g)) = NestedShape

57+type instance GenericShape (C1 c (f :*: g)) = SumOfProducts

src/Data/Swagger/Schema.hs+4

@@ -22,6 +22,10 @@ module Data.Swagger.Schema (

22 paramSchemaToNamedSchema,

23 paramSchemaToSchema,

25+ -- ** Unrestricted versions

26+ genericDeclareNamedSchemaUnrestricted,

27+ genericDeclareSchemaUnrestricted,

28+

25 -- * Schema templates

29 -- * Schema templates

26 passwordSchema,

30 passwordSchema,

27 binarySchema,

31 binarySchema,