{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.OpenApi.Internal.TypeShape where
import Data.Proxy
import GHC.Generics
import GHC.TypeLits
import GHC.Exts (Constraint)
data TypeShape
= Enumeration
| SumOfProducts
| Mixed
type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
ProdCombine Mixed b = Mixed
ProdCombine a Mixed = Mixed
ProdCombine a b = SumOfProducts
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 = ()
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."
)
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