@@ -1,15 +1,17 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE DataKinds #-}
24{-# LANGUAGE DefaultSignatures #-}
35{-# LANGUAGE FlexibleContexts #-}
46{-# LANGUAGE FlexibleInstances #-}
57{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE DataKinds #-}
78{-# LANGUAGE OverloadedLists #-}
89{-# LANGUAGE OverloadedStrings #-}
910{-# LANGUAGE PackageImports #-}
1011{-# LANGUAGE PolyKinds #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeApplications #-}
1315{-# LANGUAGE TypeFamilies #-}
1416{-# LANGUAGE TypeOperators #-}
1517{-# LANGUAGE TypeSynonymInstances #-}
@@ -59,6 +61,7 @@ import Numeric.Natural.Compat (Natural)
5961import Data.Word
6062import GHC.Generics
6163import qualified Data.UUID.Types as UUID
64+import Type.Reflection (Typeable, typeRep)
6265
6366import Data.OpenApi.Declare
6467import Data.OpenApi.Internal
@@ -858,7 +861,58 @@ data Proxy2 a b = Proxy2
858861
859862data Proxy3 a b c = Proxy3
860863
861−-- $setup
862−-- >>> import Data.OpenApi
863−-- >>> import Data.Aeson (encode)
864−-- >>> import Data.Aeson.Types (toJSONKeyText)
864+-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
865+--
866+-- Intended usage:
867+--
868+-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
869+-- >>> :{
870+-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
871+-- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
872+-- :}
873+--
874+-- >>> toNamedSchema @(Foo Int) Proxy ^. name
875+-- Just "Foo_Int"
876+-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
877+-- Just "Foo_Bool"
878+-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
879+-- Just "Foo_(Foo_Text)"
880+class ToSchema1 (f :: * -> *) where
881+ declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
882+
883+ -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
884+ -- above, however sadly GHC does not like it.
885+ default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
886+ declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
887+
888+{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
889+using 'ToSchema1' instance, like this:
890+
891+#if __GLASGOW_HASKELL__ >= 806
892+>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
893+>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
894+#else
895+> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
896+> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
897+#endif
898+-}
899+newtype BySchema1 f a = BySchema1 (f a)
900+
901+instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where
902+ declareNamedSchema _ = do
903+ sch <- declareNamedSchema1 @f @a Proxy Proxy
904+ let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
905+ return $ rename (Just tName) sch
906+
907+{- $setup
908+>>> import Data.OpenApi
909+>>> import Data.Aeson (encode)
910+>>> import Data.Aeson.Types (toJSONKeyText)
911+>>> :set -XScopedTypeVariables
912+>>> :set -XDeriveAnyClass
913+>>> :set -XStandaloneDeriving
914+>>> :set -XTypeApplications
915+#if __GLASGOW_HASKELL__ >= 806
916+>>> :set -XDerivingVia
917+#endif
918+-}