@@ -1,18 +1,43 @@
11{-# LANGUAGE CPP #-}
22{-# OPTIONS_GHC -Wno-orphans #-}
33
4+-- | __Example:__
5+--
6+-- >>> :set -XDerivingStrategies -XDerivingVia -XDeriveGeneric
7+--
8+-- >>> :{
9+-- data User = User
10+-- { userFirstName :: String,
11+-- userAge :: Maybe Integer
12+-- }
13+-- deriving stock (Generic)
14+-- deriving (FromJSON, ToJSON, ToSchema)
15+-- via CustomJSON
16+-- '[FieldLabelModifier '[StripPrefix "user", CamelToSnake], RejectUnknownFields]
17+-- User
18+-- showYaml = Data.ByteString.Char8.putStr . Data.Yaml.encode
19+-- :}
20+--
21+-- >>> showYaml $ toSchema (Proxy :: Proxy User)
22+-- type: object
23+-- properties:
24+-- first_name:
25+-- type: string
26+-- age:
27+-- type: integer
28+-- required:
29+-- - first_name
30+-- additionalProperties: false
431module Deriving.OpenApi
532 ( CustomOpenApi,
633 DatatypeNameModifier,
734 ToSchema,
835 module Deriving.Aeson,
9− Extending,
1036 )
1137where
1238
1339import Control.Lens
1440import qualified Data.Aeson.Types as A
15−import Data.Kind
1641import Data.OpenApi
1742import Data.OpenApi.Internal.Schema
1843import Data.Proxy
@@ -21,6 +46,10 @@ import Deriving.Aeson
2146import GHC.Generics
2247import GHC.TypeLits
2348
49+-- $setup
50+-- >>> import qualified Data.Yaml
51+-- >>> import qualified Data.ByteString.Char8
52+
2453#ifdef SERVANT_DESCRIPTION
2554
2655import Servant.API
@@ -30,8 +59,7 @@ import qualified Data.Text as T
3059instance (AesonOptions xs) => AesonOptions (Description f ': xs) where
3160 aesonOptions = aesonOptions @xs
3261
33−instance (OpenApiOptions xs, KnownSymbol t) => OpenApiOptions (Description t ': xs) where
34− openApiOptions = openApiOptions @xs
62+instance KnownSymbol t => OpenApiOptionModifier (Description t) where
3563 openApiSchemaModifier = schema . description <>~ Just (toTextLine @t)
3664
3765toTextLine :: forall s. KnownSymbol s => Text
@@ -41,68 +69,65 @@ toTextLine = "\n\n" <> T.pack (symbolVal (Proxy @s))
4169
4270type CustomOpenApi = CustomJSON
4371
44−instance (OpenApiOptions xs, GToSchema (Rep x), Generic x, Typeable x, Typeable xs) => ToSchema (CustomJSON xs x) where
72+instance
73+ (OpenApiOptionModifier xs, GToSchema (Rep x), Generic x, Typeable x, Typeable xs, Typeable k) =>
74+ ToSchema (CustomJSON (xs :: k) x)
75+ where
4576 declareNamedSchema Proxy =
46− openApiSchemaModifier @xs <$> genericDeclareNamedSchema (openApiOptions @xs) (Proxy @x)
77+ openApiSchemaModifier @xs
78+ <$> genericDeclareNamedSchema (openApiOptionsModifier @xs defaultSchemaOptions) (Proxy @x)
79+
80+class OpenApiOptionModifier x where
81+ openApiOptionsModifier :: SchemaOptions -> SchemaOptions
82+ openApiOptionsModifier = id
83+ openApiSchemaModifier :: NamedSchema -> NamedSchema
84+ openApiSchemaModifier = id
4785
4886data DatatypeNameModifier t
4987
50−instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (DatatypeNameModifier f ': xs) where
51− openApiOptions = (openApiOptions @xs) {datatypeNameModifier = getStringModifier @f}
88+instance (StringModifier f) => OpenApiOptionModifier (DatatypeNameModifier f) where
89+ openApiOptionsModifier o = o {datatypeNameModifier = getStringModifier @f}
5290
5391instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
5492 aesonOptions = aesonOptions @xs
5593
56−type family (++) (x :: [k]) (y :: [k]) :: [k] where
57− (++) '[] ys = ys
58− (++) (x ': xs) ys = xs ++ (x ': ys)
59−
60−type family Extending (c :: * -> *) (ee :: [*]) :: * -> * where
61− Extending (CustomJSON a) ee = CustomJSON (a ++ ee)
62−
6394-- deriving-aeson-based instances
6495
65−class OpenApiOptions (xs :: [Type]) where
66− openApiOptions :: SchemaOptions
67− openApiSchemaModifier :: NamedSchema -> NamedSchema
68− openApiSchemaModifier = id
69−
70−instance OpenApiOptions '[] where
71− openApiOptions = defaultSchemaOptions
72−
73−instance OpenApiOptions xs => OpenApiOptions (UnwrapUnaryRecords ': xs) where
74− openApiOptions = (openApiOptions @xs) {unwrapUnaryRecords = True}
96+instance OpenApiOptionModifier UnwrapUnaryRecords where
97+ openApiOptionsModifier o = o {unwrapUnaryRecords = True}
7598
76−instance OpenApiOptions xs => OpenApiOptions (OmitNothingFields ': xs) where
77− openApiOptions = openApiOptions @xs
99+instance OpenApiOptionModifier OmitNothingFields
78100
79−instance OpenApiOptions xs => OpenApiOptions (RejectUnknownFields ': xs) where
80− openApiOptions = openApiOptions @xs
101+instance OpenApiOptionModifier RejectUnknownFields where
81102 openApiSchemaModifier = schema . additionalProperties .~ Just (AdditionalPropertiesAllowed False)
82103
83−instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (FieldLabelModifier f ': xs) where
84− openApiOptions = (openApiOptions @xs) {fieldLabelModifier = getStringModifier @f}
104+instance StringModifier f => OpenApiOptionModifier (FieldLabelModifier f) where
105+ openApiOptionsModifier o = o {fieldLabelModifier = getStringModifier @f}
85106
86−instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (ConstructorTagModifier f ': xs) where
87− openApiOptions = (openApiOptions @xs) {constructorTagModifier = getStringModifier @f}
107+instance StringModifier f => OpenApiOptionModifier (ConstructorTagModifier f) where
108+ openApiOptionsModifier o = o {constructorTagModifier = getStringModifier @f}
88109
89110instance
90− (OpenApiOptions xs, TypeError ('Text "openapi3-deriving does not currently the `TagSingleConstructors` modifier.")) =>
91− OpenApiOptions (TagSingleConstructors ': xs)
92− where
93− openApiOptions = undefined
111+ TypeError ('Text "deriving-openapi3 does not currently the `TagSingleConstructors` modifier.") =>
112+ OpenApiOptionModifier TagSingleConstructors
113+
114+instance OpenApiOptionModifier NoAllNullaryToStringTag where
115+ openApiOptionsModifier o = o {allNullaryToStringTag = False}
116+
117+instance (KnownSymbol t, KnownSymbol c) => OpenApiOptionModifier (SumTaggedObject t c) where
118+ openApiOptionsModifier o = o {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
94119
95−instance OpenApiOptions xs => OpenApiOptions (NoAllNullaryToStringTag ': xs) where
96− openApiOptions = (openApiOptions @xs) {allNullaryToStringTag = False}
120+instance OpenApiOptionModifier SumUntaggedValue where
121+ openApiOptionsModifier o = o {sumEncoding = A.UntaggedValue}
97122
98−instance (KnownSymbol t, KnownSymbol c, OpenApiOptions xs) => OpenApiOptions (SumTaggedObject t c ': xs) where
99− openApiOptions = (openApiOptions @xs) {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
123+instance OpenApiOptionModifier SumObjectWithSingleField where
124+ openApiOptionsModifier o = o {sumEncoding = A.ObjectWithSingleField}
100125
101−instance (OpenApiOptions xs) => OpenApiOptions (SumUntaggedValue ': xs) where
102− openApiOptions = (openApiOptions @xs) {sumEncoding = A.UntaggedValue}
126+instance OpenApiOptionModifier SumTwoElemArray where
127+ openApiOptionsModifier o = o {sumEncoding = A.TwoElemArray}
103128
104−instance (OpenApiOptions xs) => OpenApiOptions (SumObjectWithSingleField ': xs) where
105− openApiOptions = (openApiOptions @xs) {sumEncoding = A.ObjectWithSingleField}
129+instance OpenApiOptionModifier '[]
106130
107−instance (OpenApiOptions xs) => OpenApiOptions (SumTwoElemArray ': xs) where
108− openApiOptions = (openApiOptions @xs) {sumEncoding = A.TwoElemArray}
131+instance (OpenApiOptionModifier x, OpenApiOptionModifier xs) => OpenApiOptionModifier (x ': xs) where
132+ openApiOptionsModifier = openApiOptionsModifier @xs . openApiOptionsModifier @x
133+ openApiSchemaModifier = openApiSchemaModifier @xs . openApiSchemaModifier @x