@@ -1,100 +1,139 @@
1+{-# LANGUAGE CPP #-}
12{-# OPTIONS_GHC -Wno-orphans #-}
23
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
331module Deriving.OpenApi
432 ( CustomOpenApi,
533 DatatypeNameModifier,
634 ToSchema,
735 module Deriving.Aeson,
8− Extending,
936 )
1037where
1138
1239import Control.Lens
1340import qualified Data.Aeson.Types as A
14−import Data.Kind
1541import Data.OpenApi
42+import Data.OpenApi.Internal.ParamSchema
1643import Data.OpenApi.Internal.Schema
1744import Data.Proxy
1845import Data.Text (Text)
1946import qualified Data.Text as T
47+import Data.Typeable
2048import Deriving.Aeson
2149import GHC.Generics
2250import GHC.TypeLits
23−import Servant.API
2451
25−type CustomOpenApi = CustomJSON
26−
27−instance (OpenApiOptions xs, GToSchema (Rep x), Generic x) => ToSchema (CustomJSON xs x) where
28− declareNamedSchema Proxy =
29− openApiSchemaModifier @xs <$> genericDeclareNamedSchema (openApiOptions @xs) (Proxy @x)
30−
31−data DatatypeNameModifier t
32−
33−instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (DatatypeNameModifier f ': xs) where
34− openApiOptions = (openApiOptions @xs) {datatypeNameModifier = getStringModifier @f}
35−
36−instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
37− aesonOptions = aesonOptions @xs
52+data Description (desc :: Symbol) = Description
3853
3954instance (AesonOptions xs) => AesonOptions (Description f ': xs) where
4055 aesonOptions = aesonOptions @xs
4156
42−instance (OpenApiOptions xs, KnownSymbol t) => OpenApiOptions (Description t ': xs) where
43− openApiOptions = openApiOptions @xs
57+instance KnownSymbol t => OpenApiOptionModifier (Description t) where
4458 openApiSchemaModifier = schema . description <>~ Just (toTextLine @t)
4559
4660toTextLine :: forall s. KnownSymbol s => Text
4761toTextLine = "\n\n" <> T.pack (symbolVal (Proxy @s))
4862
49−type family (++) (x :: [k]) (y :: [k]) :: [k] where
50− (++) '[] ys = ys
51− (++) (x ': xs) ys = xs ++ (x ': ys)
63+-- $setup
64+-- >>> import qualified Data.Yaml
65+-- >>> import qualified Data.ByteString.Char8
5266
53−type family Extending (c :: * -> *) (ee :: [*]) :: * -> * where
54− Extending (CustomJSON a) ee = CustomJSON (a ++ ee)
67+type CustomOpenApi = CustomJSON
5568
56−-- deriving-aeson-based instances
69+instance
70+ (OpenApiOptionModifier xs, GToSchema (Rep x), Generic x, Typeable x, Typeable xs, Typeable k) =>
71+ ToSchema (CustomJSON (xs :: k) x)
72+ where
73+ declareNamedSchema Proxy =
74+ openApiSchemaModifier @xs
75+ <$> genericDeclareNamedSchema (openApiOptionsModifier @xs defaultSchemaOptions) (Proxy @x)
5776
58−class OpenApiOptions (xs :: [Type]) where
59− openApiOptions :: SchemaOptions
77+instance
78+ (OpenApiOptionModifier xs, GToParamSchema (Rep x), Generic x) =>
79+ ToParamSchema (CustomJSON (xs :: k) x)
80+ where
81+ toParamSchema Proxy =
82+ genericToParamSchema (openApiOptionsModifier @xs defaultSchemaOptions) (Proxy @x)
83+
84+class OpenApiOptionModifier x where
85+ openApiOptionsModifier :: SchemaOptions -> SchemaOptions
86+ openApiOptionsModifier = id
6087 openApiSchemaModifier :: NamedSchema -> NamedSchema
6188 openApiSchemaModifier = id
6289
63−instance OpenApiOptions '[] where
64− openApiOptions = defaultSchemaOptions
90+data DatatypeNameModifier t
6591
66−instance OpenApiOptions xs => OpenApiOptions (UnwrapUnaryRecords ': xs) where
67− openApiOptions = (openApiOptions @xs) {unwrapUnaryRecords = True}
92+instance (StringModifier f) => OpenApiOptionModifier (DatatypeNameModifier f) where
93+ openApiOptionsModifier o = o {datatypeNameModifier = getStringModifier @f}
6894
69−instance OpenApiOptions xs => OpenApiOptions (OmitNothingFields ': xs) where
70− openApiOptions = openApiOptions @xs
95+instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
96+ aesonOptions = aesonOptions @xs
7197
72−instance OpenApiOptions xs => OpenApiOptions (RejectUnknownFields ': xs) where
73− openApiOptions = openApiOptions @xs
98+-- deriving-aeson-based instances
7499
75−instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (FieldLabelModifier f ': xs) where
76− openApiOptions = (openApiOptions @xs) {fieldLabelModifier = getStringModifier @f}
100+instance OpenApiOptionModifier UnwrapUnaryRecords where
101+ openApiOptionsModifier o = o {unwrapUnaryRecords = True}
77102
78−instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (ConstructorTagModifier f ': xs) where
79− openApiOptions = (openApiOptions @xs) {constructorTagModifier = getStringModifier @f}
103+instance OpenApiOptionModifier OmitNothingFields
104+
105+#if MIN_VERSION_deriving_aeson(0,2,4)
106+instance OpenApiOptionModifier RejectUnknownFields where
107+ openApiSchemaModifier = schema . additionalProperties .~ Just (AdditionalPropertiesAllowed False)
108+#endif
109+
110+instance StringModifier f => OpenApiOptionModifier (FieldLabelModifier f) where
111+ openApiOptionsModifier o = o {fieldLabelModifier = getStringModifier @f}
112+
113+instance StringModifier f => OpenApiOptionModifier (ConstructorTagModifier f) where
114+ openApiOptionsModifier o = o {constructorTagModifier = getStringModifier @f}
80115
81116instance
82− (OpenApiOptions xs, TypeError ( 'Text "openapi3-deriving does not currently the `TagSingleConstructors` modifier.")) =>
83− OpenApiOptions (TagSingleConstructors ': xs)
84− where
85− openApiOptions = undefined
117+ TypeError ('Text "deriving-openapi3 does not currently the `TagSingleConstructors` modifier.") =>
118+ OpenApiOptionModifier TagSingleConstructors
119+
120+instance OpenApiOptionModifier NoAllNullaryToStringTag where
121+ openApiOptionsModifier o = o {allNullaryToStringTag = False}
122+
123+instance (KnownSymbol t, KnownSymbol c) => OpenApiOptionModifier (SumTaggedObject t c) where
124+ openApiOptionsModifier o = o {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
86125
87−instance OpenApiOptions xs => OpenApiOptions (NoAllNullaryToStringTag ': xs) where
88− openApiOptions = (openApiOptions @xs) {allNullaryToStringTag = False}
126+instance OpenApiOptionModifier SumUntaggedValue where
127+ openApiOptionsModifier o = o {sumEncoding = A.UntaggedValue}
89128
90−instance (KnownSymbol t, KnownSymbol c, OpenApiOptions xs) => OpenApiOptions (SumTaggedObject t c ': xs) where
91− openApiOptions = (openApiOptions @xs) {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
129+instance OpenApiOptionModifier SumObjectWithSingleField where
130+ openApiOptionsModifier o = o {sumEncoding = A.ObjectWithSingleField}
92131
93−instance (OpenApiOptions xs) => OpenApiOptions (SumUntaggedValue ': xs) where
94− openApiOptions = (openApiOptions @xs) {sumEncoding = A.UntaggedValue}
132+instance OpenApiOptionModifier SumTwoElemArray where
133+ openApiOptionsModifier o = o {sumEncoding = A.TwoElemArray}
95134
96−instance (OpenApiOptions xs) => OpenApiOptions (SumObjectWithSingleField ': xs) where
97− openApiOptions = (openApiOptions @xs) {sumEncoding = A.ObjectWithSingleField}
135+instance OpenApiOptionModifier '[]
98136
99−instance (OpenApiOptions xs) => OpenApiOptions (SumTwoElemArray ': xs) where
100− openApiOptions = (openApiOptions @xs) {sumEncoding = A.TwoElemArray}
137+instance (OpenApiOptionModifier x, OpenApiOptionModifier xs) => OpenApiOptionModifier (x ': xs) where
138+ openApiOptionsModifier = openApiOptionsModifier @xs . openApiOptionsModifier @x
139+ openApiSchemaModifier = openApiSchemaModifier @xs . openApiSchemaModifier @x