@@ -588,7 +588,62 @@ genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
588588 , Generic a, Rep a ~ D1 d f, Datatype d)
589589 => SchemaOptions -> proxy a -> NamedSchema
590590genericToNamedSchemaBoundedIntegral opts proxy
591− = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
591+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
592+
593+-- | Declare a named schema for a @newtype@ wrapper.
594+genericDeclareNamedSchemaNewtype :: forall proxy a d c s i inner.
595+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
596+ => SchemaOptions -- ^ How to derive the name.
597+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
598+ -> proxy a
599+ -> Declare (Definitions Schema) NamedSchema
600+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
601+
602+-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
603+-- This makes a much more useful schema when there aren't many options for key values.
604+--
605+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
606+-- >>> instance ToJSON ButtonState
607+-- >>> instance ToSchema ButtonState
608+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
609+-- >>> type ImageUrl = T.Text
610+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
611+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
612+--
613+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
614+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
615+declareSchemaBoundedEnumKeyMapping :: forall map key value proxy.
616+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
617+ => proxy (map key value) -> Declare (Definitions Schema) Schema
618+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
619+ ToJSONKeyText keyToText _ -> objectSchema keyToText
620+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
621+ where
622+ objectSchema keyToText = do
623+ valueRef <- declareSchemaRef (Proxy :: Proxy value)
624+ let allKeys = [minBound..maxBound :: key]
625+ mkPair k = (keyToText k, valueRef)
626+ return $ mempty
627+ & type_ .~ SwaggerObject
628+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
629+
630+-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
631+-- This makes a much more useful schema when there aren't many options for key values.
632+--
633+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
634+-- >>> instance ToJSON ButtonState
635+-- >>> instance ToSchema ButtonState
636+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
637+-- >>> type ImageUrl = T.Text
638+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
639+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
640+--
641+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
642+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
643+toSchemaBoundedEnumKeyMapping :: forall map key value proxy.
644+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
645+ => proxy (map key value) -> Schema
646+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
592647
593648-- | A configurable generic @'Schema'@ creator.
594649genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
@@ -618,6 +673,12 @@ genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (
618673 SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
619674genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
620675
676+-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
677+genericNameSchema :: forall a d f proxy.
678+ (Generic a, Rep a ~ D1 d f, Datatype d)
679+ => SchemaOptions -> proxy a -> Schema -> NamedSchema
680+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
681+
621682gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
622683gdatatypeSchemaName opts _ = case name of
623684 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
@@ -629,7 +690,7 @@ gdatatypeSchemaName opts _ = case name of
629690paramSchemaToNamedSchema :: forall a d f proxy.
630691 (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
631692 => SchemaOptions -> proxy a -> NamedSchema
632−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
693+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
633694
634695-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
635696paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
@@ -797,3 +858,4 @@ data Proxy3 a b c = Proxy3
797858-- $setup
798859-- >>> import Data.Swagger
799860-- >>> import Data.Aeson (encode)
861+-- >>> import Data.Aeson.Types (toJSONKeyText)