From e087c746b95c0ab8d3757ddbdf9067aac5aaa780 Mon Sep 17 00:00:00 2001 From: iko Date: Sat, 6 Feb 2021 15:49:27 +0300 Subject: [PATCH 1/2] Better parametric polymorphism type names --- src/Data/OpenApi/Internal/Schema.hs | 37 ++++++++++++++++------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index 1ea3ead0..c6f901a5 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -140,7 +140,7 @@ class ToSchema a where -- Note that the schema itself is included in definitions -- only if it is recursive (and thus needs its definition in scope). declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema - default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => + default declareNamedSchema :: (Generic a, GToSchema (Rep a), Typeable a) => Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions @@ -429,7 +429,7 @@ instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain instance ToSchema a => ToSchema (Maybe a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a) -instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where +instance (ToSchema a, ToSchema b, Typeable a, Typeable b) => ToSchema (Either a b) where -- To match Aeson instance declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions { sumEncoding = ObjectWithSingleField } @@ -441,12 +441,12 @@ instance ToSchema UUID.UUID where declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p & example ?~ toJSON (UUID.toText UUID.nil) -instance (ToSchema a, ToSchema b) => ToSchema (a, b) -instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f) -instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) +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) +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) +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) timeSchema :: T.Text -> Schema timeSchema fmt = mempty @@ -497,10 +497,10 @@ instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int)) -- | NOTE: This schema does not account for the uniqueness of keys. -instance ToSchema a => ToSchema (IntMap a) where +instance (ToSchema a, Typeable a) => ToSchema (IntMap a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)]) -instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where +instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (Map k v) where declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of ToJSONKeyText _ _ -> declareObjectMapSchema ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)]) @@ -511,7 +511,7 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where & type_ ?~ OpenApiObject & additionalProperties ?~ AdditionalPropertiesSchema schema -instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where +instance (ToJSONKey k, ToSchema k, ToSchema v, Typeable k, Typeable v) => ToSchema (HashMap k v) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v)) instance {-# OVERLAPPING #-} ToSchema Object where @@ -592,7 +592,7 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. declareSchemaBoundedEnumKeyMapping :: forall map key value. - (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value) => Proxy (map key value) -> Declare (Definitions Schema) Schema declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of ToJSONKeyText keyToText _ -> objectSchema keyToText @@ -620,12 +620,12 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o -- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'. -- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used. toSchemaBoundedEnumKeyMapping :: forall map key value. - (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value) + (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value, Typeable key, Typeable value) => Proxy (map key value) -> Schema toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping -- | A configurable generic @'Schema'@ creator. -genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => +genericDeclareSchema :: (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy @@ -633,9 +633,12 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche -- This function applied to @'defaultSchemaOptions'@ -- is used as the default for @'declareNamedSchema'@ -- when the type is an instance of @'Generic'@. -genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a)) => +genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema -genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty +genericDeclareNamedSchema opts _ = + rename (Just tName) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + where tName = T.replace " " "_" $ T.pack $ show $ typeRep @a + -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. genericNameSchema :: forall a d f. @@ -882,7 +885,7 @@ class ToSchema1 (f :: * -> *) where -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method -- above, however sadly GHC does not like it. - default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a))) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema + default declareNamedSchema1 :: forall a. (ToSchema a, Generic (f a), GToSchema (Rep (f a)), Typeable (f a)) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema declareNamedSchema1 _ _ = genericDeclareNamedSchema @(f a) defaultSchemaOptions Proxy {- | For GHC 8.6+ it's more convenient to use @DerivingVia@ to derive instances of 'ToSchema' From 495dcaf4b8faa8bfe931525dd6f564459addc842 Mon Sep 17 00:00:00 2001 From: iko Date: Sat, 6 Feb 2021 16:50:50 +0300 Subject: [PATCH 2/2] Fixed tests --- src/Data/OpenApi/Internal/Schema.hs | 30 +++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/src/Data/OpenApi/Internal/Schema.hs b/src/Data/OpenApi/Internal/Schema.hs index c6f901a5..cbb3d959 100644 --- a/src/Data/OpenApi/Internal/Schema.hs +++ b/src/Data/OpenApi/Internal/Schema.hs @@ -441,12 +441,18 @@ instance ToSchema UUID.UUID where declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p & example ?~ toJSON (UUID.toText UUID.nil) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) -instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) -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) -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) -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) +instance (ToSchema a, Typeable a, ToSchema b, Typeable b) => ToSchema (a, b) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c) => ToSchema (a, b, c) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +instance (ToSchema a, Typeable a, ToSchema b, Typeable b, ToSchema c, Typeable c, ToSchema d, Typeable d) => ToSchema (a, b, c, d) where + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +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 + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +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 + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions +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 + declareNamedSchema = fmap unname . genericDeclareNamedSchema defaultSchemaOptions timeSchema :: T.Text -> Schema timeSchema fmt = mempty @@ -636,8 +642,12 @@ genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSche genericDeclareNamedSchema :: forall a. (Generic a, GToSchema (Rep a), Typeable a) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema genericDeclareNamedSchema opts _ = - rename (Just tName) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty - where tName = T.replace " " "_" $ T.pack $ show $ typeRep @a + rename (Just $ T.pack name) <$> gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty + where + unspace ' ' = '_' + unspace x = x + orig = fmap unspace $ show $ typeRep @a + name = datatypeNameModifier opts orig -- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'. @@ -881,7 +891,7 @@ data Proxy3 a b c = Proxy3 -- >>> toNamedSchema @(Foo (Foo T.Text)) Proxy ^. name -- Just "Foo_(Foo_Text)" class ToSchema1 (f :: * -> *) where - declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema + declareNamedSchema1 :: (Generic (f a), GToSchema (Rep (f a)), ToSchema a, Typeable a) => Proxy f -> Proxy a -> Declare (Definitions Schema) NamedSchema -- It would be cleaner to have GToSchema constraint only on default signature and not in the class method -- above, however sadly GHC does not like it. @@ -901,7 +911,7 @@ using 'ToSchema1' instance, like this: -} newtype BySchema1 f a = BySchema1 (f a) -instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a) => ToSchema (BySchema1 f a) where +instance (ToSchema1 f, Generic (f a), GToSchema (Rep (f a)), Typeable (f a), ToSchema a, Typeable a) => ToSchema (BySchema1 f a) where declareNamedSchema _ = do sch <- declareNamedSchema1 @f @a Proxy Proxy let tName = T.replace " " "_" $ T.pack $ show $ typeRep @(f a)