@@ -1,60 +1,59 @@
1−
2−{-# LANGUAGE KindSignatures #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE TypeOperators #-}
6−{-# LANGUAGE UndecidableInstances #-}
7−
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE KindSignatures #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE UndecidableInstances #-}
87
98module Data.Swagger.Internal.TypeShape where
109
11−
1210import Data.Proxy
1311import GHC.Generics
1412import GHC.TypeLits
15−
16−data TypeShape = EnumShape
17− | NestedShape
18− | IlegalShape
19−
20−
21−type family ProdCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where
22−
23− ProdCombine IlegalShape b = IlegalShape
24− ProdCombine a IlegalShape = IlegalShape
25− ProdCombine a b = NestedShape
26−
27−
28−type family SumCombine (a :: TypeShape ) (b :: TypeShape) :: TypeShape where
29−
30− SumCombine EnumShape EnumShape = EnumShape
31− SumCombine NestedShape NestedShape = NestedShape
32− SumCombine a b = IlegalShape
33−
34−
35−
36−
37−class LegalShape (a :: TypeShape) where
38−
39−instance LegalShape EnumShape
40−instance LegalShape NestedShape
41−
42−instance TypeError
43− ( Text "Cannot auto derive swagger class, for that to be possible, make sure that any constructor "
44− :$$: Text "for this type, only holds 0 arguments if there are no other contructors with more than 0 arguments,"
45− :$$: Text "otherwise, every constructor have to hold at least 1 argument"
46− ) => LegalShape IlegalShape
47−
48−
49−
50−type family GenericShape ( g :: * -> * ) :: TypeShape
51−
13+import GHC.Exts (Constraint)
14+
15+-- | Shape of a datatype.
16+data TypeShape
17+ = Enumeration -- ^ A simple enumeration.
18+ | SumOfProducts -- ^ A product or a sum of non-unit products.
19+ | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
20+
21+-- | A combined shape for a product type.
22+type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
23+ ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
24+ ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
25+ ProdCombine a b = SumOfProducts
26+
27+-- | A combined shape for a sum type.
28+type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
29+ SumCombine Enumeration Enumeration = Enumeration
30+ SumCombine SumOfProducts SumOfProducts = SumOfProducts
31+ SumCombine a b = Mixed
32+
33+type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
34+ TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
35+
36+type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
37+ GenericHasSimpleShape t f Enumeration = ()
38+ GenericHasSimpleShape t f SumOfProducts = ()
39+ GenericHasSimpleShape t f Mixed =
40+ TypeError
41+ ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
42+ :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
43+ :$$: Text "Swagger does not have a good representation for these types."
44+ :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
45+ :$$: Text "that matches aeson's Generic-based toJSON,"
46+ :$$: Text "but that's not supported by some Swagger tools."
47+ )
48+
49+-- | Infer a 'TypeShape' for a generic representation of a type.
50+type family GenericShape (g :: * -> *) :: TypeShape
5251
5352type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
5453type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
5554type instance GenericShape (D1 d f) = GenericShape f
56−type instance GenericShape (C1 c U1) = EnumShape
57−type instance GenericShape (C1 c (S1 s f)) = NestedShape
58−type instance GenericShape (C1 c (f :*: g)) = NestedShape
55+type instance GenericShape (C1 c U1) = Enumeration
56+type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
57+type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
5958
6059