@@ -64,14 +64,13 @@ import GHC.Generics
6464import qualified Data.UUID.Types as UUID
6565import Type.Reflection (Typeable, typeRep)
6666
67−import Data.OpenApi.Aeson.Compat (keyToText, objectKeys, toInsOrdHashMap)
68−import Data.OpenApi.Declare
69−import Data.OpenApi.Internal
70−import Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
71−import Data.OpenApi.Internal.TypeShape
72−import Data.OpenApi.Lens hiding (name, schema)
73−import qualified Data.OpenApi.Lens as Swagger
74−import Data.OpenApi.SchemaOptions
67+import Data.OpenApi.Declare
68+import Data.OpenApi.Internal
69+import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
70+import Data.OpenApi.Lens hiding (name, schema)
71+import qualified Data.OpenApi.Lens as Swagger
72+import Data.OpenApi.SchemaOptions
73+import Data.OpenApi.Internal.TypeShape
7574
7675import qualified Data.ByteString as BS
7776import qualified Data.ByteString.Lazy.Char8 as BSL
@@ -136,13 +135,13 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
136135--
137136-- instance ToSchema Coord
138137-- @
139−class Typeable a => ToSchema a where
138+class ToSchema a where
140139 -- | Convert a type into an optionally named schema
141140 -- together with all used definitions.
142141 -- Note that the schema itself is included in definitions
143142 -- only if it is recursive (and thus needs its definition in scope).
144143 declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
145− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) =>
144+ default declareNamedSchema :: (Generic a, GToSchema (Rep a), Typeable a) =>
146145 Proxy a -> Declare (Definitions Schema) NamedSchema
147146 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
148147
@@ -406,8 +405,8 @@ sketchSchema = sketch . toJSON
406405 _ -> Nothing
407406 go (Object o) = mempty
408407 & type_ ?~ OpenApiObject
409− & required .~ sort (objectKeys o)
410− & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
408+ & required .~ sort (HashMap.keys o)
409+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
411410
412411-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
413412-- Produced schema uses as much constraints as possible.
@@ -571,12 +570,12 @@ sketchStrictSchema = go . toJSON
571570 go js@(Object o) = mempty
572571 & type_ ?~ OpenApiObject
573572 & required .~ sort names
574− & properties .~ fmap (Inline . go) (toInsOrdHashMap o)
573+ & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
575574 & maxProperties ?~ fromIntegral (length names)
576575 & minProperties ?~ fromIntegral (length names)
577576 & enum_ ?~ [js]
578577 where
579− names = objectKeys o
578+ names = HashMap.keys o
580579
581580class GToSchema (f :: * -> *) where
582581 gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
@@ -611,12 +610,12 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
611610instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
612611instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
613612
614−instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
613+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
615614
616615instance ToSchema a => ToSchema (Maybe a) where
617616 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
618617
619−instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
618+instance (ToSchema a, ToSchema b, Typeable a, Typeable b) => ToSchema (Either a b) where
620619 -- To match Aeson instance
621620 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField }
622621
@@ -628,17 +627,17 @@ instance ToSchema UUID.UUID where
628627 declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
629628 & example ?~ toJSON (UUID.toText UUID.nil)
630629
631−instance (ToSchema a, ToSchema b) => ToSchema (a, b) where
630+instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) where
632631 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
633−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) where
632+instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) where
634633 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
635−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) where
634+instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) where
636635 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
637−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) where
636+instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e) => ToSchema (a, b, c, d, e) where
638637 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
639−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) where
638+instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f) => ToSchema (a, b, c, d, e, f) where
640639 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
641−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) where
640+instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d, ToSchema e, Typeable e, ToSchema f, Typeable f, ToSchema g, Typeable g) => ToSchema (a, b, c, d, e, f, g) where
642641 declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions
643642
644643timeSchema :: T.Text -> Schema
@@ -658,7 +657,7 @@ instance ToSchema LocalTime where
658657 declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
659658 & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
660659
661−-- | Format @"date-time"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
660+-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
662661instance ToSchema ZonedTime where
663662 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
664663 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
@@ -690,10 +689,10 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where
690689instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
691690
692691-- | NOTE: This schema does not account for the uniqueness of keys.
693−instance (ToSchema a) => ToSchema (IntMap a) where
692+instance (ToSchema a, Typeable a) => ToSchema (IntMap a) where
694693 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
695694
696−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
695+instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (Map k v) where
697696 declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
698697 ToJSONKeyText _ _ -> declareObjectMapSchema
699698 ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
@@ -704,7 +703,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
704703 & type_ ?~ OpenApiObject
705704 & additionalProperties ?~ AdditionalPropertiesSchema schema
706705
707−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
706+instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (HashMap k v) where
708707 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
709708
710709instance {-# OVERLAPPING #-} ToSchema Object where
@@ -808,16 +807,16 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$>
808807-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
809808-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
810809declareSchemaBoundedEnumKeyMapping :: forall map key value.
811− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
810+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value)
812811 => Proxy (map key value) -> Declare (Definitions Schema) Schema
813812declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
814− ToJSONKeyText getKey _ -> objectSchema getKey
813+ ToJSONKeyText keyToText _ -> objectSchema keyToText
815814 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
816815 where
817− objectSchema getKey = do
816+ objectSchema keyToText = do
818817 valueRef <- declareSchemaRef (Proxy :: Proxy value)
819818 let allKeys = [minBound..maxBound :: key]
820− mkPair k = (keyToText $ getKey k, valueRef)
819+ mkPair k = (keyToText k, valueRef)
821820 return $ mempty
822821 & type_ ?~ OpenApiObject
823822 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
@@ -855,7 +854,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
855854-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
856855-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
857856toSchemaBoundedEnumKeyMapping :: forall map key value.
858− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
857+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value)
859858 => Proxy (map key value) -> Schema
860859toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
861860
@@ -868,14 +867,6 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche
868867-- This function applied to @'defaultSchemaOptions'@
869868-- is used as the default for @'declareNamedSchema'@
870869-- when the type is an instance of @'Generic'@.
871−--
872−-- Default implementation will use the name from 'Typeable' instance, including concrete
873−-- instantioations of type variables.
874−--
875−-- For example:
876−--
877−-- >>> _namedSchemaName $ undeclare $ genericDeclareNamedSchema defaultSchemaOptions (Proxy :: Proxy (Either Int Bool))
878−-- Just "Either_Int_Bool"
879870genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) =>
880871 SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
881872genericDeclareNamedSchema opts _ =
@@ -945,13 +936,10 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
945936 case schema ^. items of
946937 Just (OpenApiItemsArray [_]) -> fieldSchema
947938 _ -> do
948− -- We have to run recordSchema instead of just using its defs,
949− -- since those can be recursive and will lead to infinite loop,
950− -- see https://github.com/biocad/openapi3/pull/37
951− NamedSchema _ schema' <- recordSchema
952− return (unnamed schema')
939+ declare defs
940+ return (unnamed schema)
953941 where
954− (_, NamedSchema _ schema) = runDeclare recordSchema mempty
942+ (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
955943 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
956944 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
957945
@@ -1114,6 +1102,49 @@ data Proxy2 a b = Proxy2
11141102
11151103data Proxy3 a b c = Proxy3
11161104
1105+-- | This class allows to generate schemas for polymorphic types (of kind @Type -> Type@).
1106+--
1107+-- Intended usage:
1108+--
1109+-- >>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1110+-- >>> :{
1111+-- instance (ToSchema a, Typeable a) => ToSchema (Foo a) where
1112+-- declareNamedSchema _ = declareNamedSchema @(BySchema1 Foo a) Proxy
1113+-- :}
1114+--
1115+-- >>> toNamedSchema @(Foo Int) Proxy ^. name
1116+-- Just "Foo_Int"
1117+-- >>> toNamedSchema @(Foo Bool) Proxy ^. name
1118+-- Just "Foo_Bool"
1119+-- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name
1120+-- Just "Foo_(Foo_Text)"
1121+class ToSchema1 (f :: * -> *) where
1122+ declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a, Typeable a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1123+
1124+ -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method
1125+ -- above, however sadly GHC does not like it.
1126+ default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a)), Typeable (f a)) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema
1127+ declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy
1128+
1129+{- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema'
1130+using 'ToSchema1' instance, like this:
1131+
1132+#if __GLASGOW_HASKELL__ >= 806
1133+>>> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1134+>>> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1135+#else
1136+> data Foo a = Foo { foo :: a, bar :: Int } deriving (Eq, Show, Generic, ToSchema1)
1137+> deriving via BySchema1 Foo a instance (ToSchema a, Typeable a) => ToSchema (Foo a)
1138+#endif
1139+-}
1140+newtype BySchema1 f a = BySchema1 (f a)
1141+
1142+instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a, Typeable a) => ToSchema (BySchema1 f a) where
1143+ declareNamedSchema _ = do
1144+ sch <- declareNamedSchema1 @f @a Proxy Proxy
1145+ let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)
1146+ return $ rename (Just tName) sch
1147+
11171148{- $setup
11181149>>> import Data.OpenApi
11191150>>> import Data.Aeson (encode)
@@ -1123,4 +1154,7 @@ data Proxy3 a b c = Proxy3
11231154>>> :set -XDeriveAnyClass
11241155>>> :set -XStandaloneDeriving
11251156>>> :set -XTypeApplications
1157+#if __GLASGOW_HASKELL__ >= 806
1158+>>> :set -XDerivingVia
1159+#endif
11261160-}