TypeShape.hs

-- |
-- Module:      Data.OpenApi.Internal.TypeShape
-- Maintainer:  Nadeem Bitar <nadeem@gmail.com>
-- Stability:   experimental
--
-- Internal type-level machinery classifying the generic shape of a datatype
-- (used to reject unsupported sum/product mixes). No API stability guarantees.
module Data.OpenApi.Internal.TypeShape where

import Data.Kind (Type)
import Data.Proxy
import GHC.Exts (Constraint)
import GHC.Generics
import GHC.TypeLits

-- | Shape of a datatype.
data TypeShape
  = -- | A simple enumeration.
    Enumeration
  | -- | A product or a sum of non-unit products.
    SumOfProducts
  | -- | Mixed sum type with both unit and non-unit constructors.
    Mixed

-- | 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 = ()
  GenericHasSimpleShape t f Mixed =
    TypeError
      ( Text "Cannot derive Generic-based OpenAPI Schema for " :<>: ShowType t
          :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
          :$$: Text "OpenAPI 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 OpenAPI tools."
      )

-- | Infer a 'TypeShape' for a generic representation of a type.
type family GenericShape (g :: Type -> Type) :: 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