Skip to content

Support polymorphic types by default #13

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
ilyakooo0 wants to merge 2 commits into from
Closed

Support polymorphic types by default #13

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
e087c74
Better parametric polymorphism type names
ilyakooo0 Feb 6, 2021
495dcaf
Fixed tests
ilyakooo0 Feb 6, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
51 changes: 32 additions & 19 deletions src/Data/OpenApi/Internal/Schema.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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 }

Expand All @@ -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, 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) 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
Expand Down Expand Up @@ -497,10 +503,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)])
Expand All @@ -511,7 +517,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
Expand Down Expand Up @@ -592,7 +598,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
Expand Down Expand Up @@ -620,22 +626,29 @@ 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

-- | A configurable generic @'NamedSchema'@ creator.
-- 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 $ 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'.
genericNameSchema :: forall a d f.
Expand Down Expand Up @@ -878,11 +891,11 @@ 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.
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'
Expand All @@ -898,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)
Expand Down