@@ -1,45 +1,18 @@
1−{-# LANGUAGE CPP #-}
21{-# OPTIONS_GHC -Wno-orphans #-}
32
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
313module Deriving.OpenApi
324 ( CustomOpenApi,
335 DatatypeNameModifier,
346 ToSchema,
357 module Deriving.Aeson,
8+ Extending,
369 )
3710where
3811
3912import Control.Lens
4013import qualified Data.Aeson.Types as A
14+import Data.Kind
4115import Data.OpenApi
42−import Data.OpenApi.Internal.ParamSchema
4316import Data.OpenApi.Internal.Schema
4417import Data.Proxy
4518import Data.Text (Text)
@@ -48,92 +21,82 @@ import Data.Typeable
4821import Deriving.Aeson
4922import GHC.Generics
5023import GHC.TypeLits
24+import Servant.API
5125
52−data Description (desc :: Symbol) = Description
26+type CustomOpenApi = CustomJSON
27+
28+instance (OpenApiOptions xs, GToSchema (Rep x), Generic x, Typeable x, Typeable xs) => ToSchema (CustomJSON xs x) where
29+ declareNamedSchema Proxy =
30+ openApiSchemaModifier @xs <$> genericDeclareNamedSchema (openApiOptions @xs) (Proxy @x)
31+
32+data DatatypeNameModifier t
33+
34+instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (DatatypeNameModifier f ': xs) where
35+ openApiOptions = (openApiOptions @xs) {datatypeNameModifier = getStringModifier @f}
36+
37+instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
38+ aesonOptions = aesonOptions @xs
5339
5440instance (AesonOptions xs) => AesonOptions (Description f ': xs) where
5541 aesonOptions = aesonOptions @xs
5642
57−instance KnownSymbol t => OpenApiOptionModifier (Description t) where
43+instance (OpenApiOptions xs, KnownSymbol t) => OpenApiOptions (Description t ': xs) where
44+ openApiOptions = openApiOptions @xs
5845 openApiSchemaModifier = schema . description <>~ Just (toTextLine @t)
5946
6047toTextLine :: forall s. KnownSymbol s => Text
6148toTextLine = "\n\n" <> T.pack (symbolVal (Proxy @s))
6249
63−-- $setup
64−-- >>> import qualified Data.Yaml
65−-- >>> import qualified Data.ByteString.Char8
66−
67−type CustomOpenApi = CustomJSON
50+type family (++) (x :: [k]) (y :: [k]) :: [k] where
51+ (++) '[] ys = ys
52+ (++) (x ': xs) ys = xs ++ (x ': ys)
6853
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)
54+type family Extending (c :: * -> *) (ee :: [*]) :: * -> * where
55+ Extending (CustomJSON a) ee = CustomJSON (a ++ ee)
7656
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)
57+-- deriving-aeson-based instances
8358
84−class OpenApiOptionModifier x where
85− openApiOptionsModifier :: SchemaOptions -> SchemaOptions
86− openApiOptionsModifier = id
59+class OpenApiOptions (xs :: [Type]) where
60+ openApiOptions :: SchemaOptions
8761 openApiSchemaModifier :: NamedSchema -> NamedSchema
8862 openApiSchemaModifier = id
8963
90−data DatatypeNameModifier t
64+instance OpenApiOptions '[] where
65+ openApiOptions = defaultSchemaOptions
9166
92−instance (StringModifier f) => OpenApiOptionModifier (DatatypeNameModifier f) where
93− openApiOptionsModifier o = o {datatypeNameModifier = getStringModifier @f}
67+instance OpenApiOptions xs => OpenApiOptions (UnwrapUnaryRecords ': xs) where
68+ openApiOptions = (openApiOptions @xs) {unwrapUnaryRecords = True}
9469
95−instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
96− aesonOptions = aesonOptions @xs
70+instance OpenApiOptions xs => OpenApiOptions (OmitNothingFields ': xs) where
71+ openApiOptions = openApiOptions @xs
9772
98−-- deriving-aeson-based instances
99−
100−instance OpenApiOptionModifier UnwrapUnaryRecords where
101− openApiOptionsModifier o = o {unwrapUnaryRecords = True}
102−
103−instance OpenApiOptionModifier OmitNothingFields
104−
105−#if MIN_VERSION_deriving_aeson(0,2,4)
106−instance OpenApiOptionModifier RejectUnknownFields where
73+instance OpenApiOptions xs => OpenApiOptions (RejectUnknownFields ': xs) where
74+ openApiOptions = openApiOptions @xs
10775 openApiSchemaModifier = schema . additionalProperties .~ Just (AdditionalPropertiesAllowed False)
108−#endif
10976
110−instance StringModifier f => OpenApiOptionModifier (FieldLabelModifier f) where
111− openApiOptionsModifier o = o {fieldLabelModifier = getStringModifier @f}
77+instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (FieldLabelModifier f ': xs) where
78+ openApiOptions = (openApiOptions @xs) {fieldLabelModifier = getStringModifier @f}
11279
113−instance StringModifier f => OpenApiOptionModifier (ConstructorTagModifier f) where
114− openApiOptionsModifier o = o {constructorTagModifier = getStringModifier @f}
80+instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (ConstructorTagModifier f ': xs) where
81+ openApiOptions = (openApiOptions @xs) {constructorTagModifier = getStringModifier @f}
11582
11683instance
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))}
84+ (OpenApiOptions xs, TypeError ('Text "openapi3-deriving does not currently the `TagSingleConstructors` modifier.")) =>
85+ OpenApiOptions (TagSingleConstructors ': xs)
86+ where
87+ openApiOptions = undefined
12588
126−instance OpenApiOptionModifier SumUntaggedValue where
127− openApiOptionsModifier o = o {sumEncoding = A.UntaggedValue}
89+instance OpenApiOptions xs => OpenApiOptions (NoAllNullaryToStringTag ': xs) where
90+ openApiOptions = (openApiOptions @xs) {allNullaryToStringTag = False}
12891
129−instance OpenApiOptionModifier SumObjectWithSingleField where
130− openApiOptionsModifier o = o {sumEncoding = A.ObjectWithSingleField}
92+instance (KnownSymbol t, KnownSymbol c, OpenApiOptions xs) => OpenApiOptions (SumTaggedObject t c ': xs) where
93+ openApiOptions = (openApiOptions @xs) {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
13194
132−instance OpenApiOptionModifier SumTwoElemArray where
133− openApiOptionsModifier o = o {sumEncoding = A.TwoElemArray}
95+instance (OpenApiOptions xs) => OpenApiOptions (SumUntaggedValue ': xs) where
96+ openApiOptions = (openApiOptions @xs) {sumEncoding = A.UntaggedValue}
13497
135−instance OpenApiOptionModifier '[]
98+instance (OpenApiOptions xs) => OpenApiOptions (SumObjectWithSingleField ': xs) where
99+ openApiOptions = (openApiOptions @xs) {sumEncoding = A.ObjectWithSingleField}
136100
137−instance (OpenApiOptionModifier x, OpenApiOptionModifier xs) => OpenApiOptionModifier (x ': xs) where
138− openApiOptionsModifier = openApiOptionsModifier @xs . openApiOptionsModifier @x
139− openApiSchemaModifier = openApiSchemaModifier @xs . openApiSchemaModifier @x
101+instance (OpenApiOptions xs) => OpenApiOptions (SumTwoElemArray ': xs) where
102+ openApiOptions = (openApiOptions @xs) {sumEncoding = A.TwoElemArray}