mirror of
https://github.com/ilyakooo0/deriving-openapi3.git
synced 2024-08-17 06:20:21 +03:00
Rewrote everything and added doctests
This commit is contained in:
parent
70c6973f20
commit
a7837a187a
5
.github/workflows/build.yaml
vendored
5
.github/workflows/build.yaml
vendored
@ -47,6 +47,11 @@ jobs:
|
|||||||
run: |
|
run: |
|
||||||
stack build
|
stack build
|
||||||
|
|
||||||
|
- name: doctests
|
||||||
|
shell: bash
|
||||||
|
run: |
|
||||||
|
./runDoctests.sh
|
||||||
|
|
||||||
- name: Check Formatting
|
- name: Check Formatting
|
||||||
shell: bash
|
shell: bash
|
||||||
run: |
|
run: |
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
name: deriving-openapi3
|
name: deriving-openapi3
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
synopsis: DerivingVia for OpenAPI 3
|
synopsis: DerivingVia for OpenAPI 3
|
||||||
description: See <https://github.com/ilyakooo0/deriving-openapi3 GitHub> for more details.
|
description: DerivingVia for OpenAPI 3
|
||||||
maintainer: Ilya Kostyuchenko <ilyakooo0@gmail.com>
|
maintainer: Ilya Kostyuchenko <ilyakooo0@gmail.com>
|
||||||
category: JSON, Generics, OpenAPI
|
category: JSON, Generics, OpenAPI
|
||||||
license: MIT
|
license: MIT
|
||||||
@ -42,6 +42,8 @@ default-extensions:
|
|||||||
- TypeFamilies
|
- TypeFamilies
|
||||||
- PolyKinds
|
- PolyKinds
|
||||||
- OverloadedStrings
|
- OverloadedStrings
|
||||||
|
- DerivingStrategies
|
||||||
|
- DerivingVia
|
||||||
flags:
|
flags:
|
||||||
servant-description:
|
servant-description:
|
||||||
description: Create instances for the 'Description' type from 'servant'
|
description: Create instances for the 'Description' type from 'servant'
|
||||||
|
9
runDoctests.sh
Executable file
9
runDoctests.sh
Executable file
@ -0,0 +1,9 @@
|
|||||||
|
#!/bin/sh
|
||||||
|
|
||||||
|
set -e
|
||||||
|
|
||||||
|
EXTENSIONS="-XAllowAmbiguousTypes -XScopedTypeVariables -XKindSignatures -XDataKinds -XTypeOperators -XFlexibleInstances -XTypeApplications -XUndecidableInstances -XTypeFamilies -XPolyKinds"
|
||||||
|
|
||||||
|
DEPENDENCIES="--package doctest --package yaml"
|
||||||
|
|
||||||
|
stack exec $DEPENDENCIES -- find src -name '*.hs' -exec doctest $EXTENSIONS '{}' \;
|
@ -1,18 +1,43 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
|
-- | __Example:__
|
||||||
|
--
|
||||||
|
-- >>> :set -XDerivingStrategies -XDerivingVia -XDeriveGeneric
|
||||||
|
--
|
||||||
|
-- >>> :{
|
||||||
|
-- data User = User
|
||||||
|
-- { userFirstName :: String,
|
||||||
|
-- userAge :: Maybe Integer
|
||||||
|
-- }
|
||||||
|
-- deriving stock (Generic)
|
||||||
|
-- deriving (FromJSON, ToJSON, ToSchema)
|
||||||
|
-- via CustomJSON
|
||||||
|
-- '[FieldLabelModifier '[StripPrefix "user", CamelToSnake], RejectUnknownFields]
|
||||||
|
-- User
|
||||||
|
-- showYaml = Data.ByteString.Char8.putStr . Data.Yaml.encode
|
||||||
|
-- :}
|
||||||
|
--
|
||||||
|
-- >>> showYaml $ toSchema (Proxy :: Proxy User)
|
||||||
|
-- type: object
|
||||||
|
-- properties:
|
||||||
|
-- first_name:
|
||||||
|
-- type: string
|
||||||
|
-- age:
|
||||||
|
-- type: integer
|
||||||
|
-- required:
|
||||||
|
-- - first_name
|
||||||
|
-- additionalProperties: false
|
||||||
module Deriving.OpenApi
|
module Deriving.OpenApi
|
||||||
( CustomOpenApi,
|
( CustomOpenApi,
|
||||||
DatatypeNameModifier,
|
DatatypeNameModifier,
|
||||||
ToSchema,
|
ToSchema,
|
||||||
module Deriving.Aeson,
|
module Deriving.Aeson,
|
||||||
Extending,
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
import qualified Data.Aeson.Types as A
|
import qualified Data.Aeson.Types as A
|
||||||
import Data.Kind
|
|
||||||
import Data.OpenApi
|
import Data.OpenApi
|
||||||
import Data.OpenApi.Internal.Schema
|
import Data.OpenApi.Internal.Schema
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
@ -21,6 +46,10 @@ import Deriving.Aeson
|
|||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
|
|
||||||
|
-- $setup
|
||||||
|
-- >>> import qualified Data.Yaml
|
||||||
|
-- >>> import qualified Data.ByteString.Char8
|
||||||
|
|
||||||
#ifdef SERVANT_DESCRIPTION
|
#ifdef SERVANT_DESCRIPTION
|
||||||
|
|
||||||
import Servant.API
|
import Servant.API
|
||||||
@ -30,8 +59,7 @@ import qualified Data.Text as T
|
|||||||
instance (AesonOptions xs) => AesonOptions (Description f ': xs) where
|
instance (AesonOptions xs) => AesonOptions (Description f ': xs) where
|
||||||
aesonOptions = aesonOptions @xs
|
aesonOptions = aesonOptions @xs
|
||||||
|
|
||||||
instance (OpenApiOptions xs, KnownSymbol t) => OpenApiOptions (Description t ': xs) where
|
instance KnownSymbol t => OpenApiOptionModifier (Description t) where
|
||||||
openApiOptions = openApiOptions @xs
|
|
||||||
openApiSchemaModifier = schema . description <>~ Just (toTextLine @t)
|
openApiSchemaModifier = schema . description <>~ Just (toTextLine @t)
|
||||||
|
|
||||||
toTextLine :: forall s. KnownSymbol s => Text
|
toTextLine :: forall s. KnownSymbol s => Text
|
||||||
@ -41,68 +69,65 @@ toTextLine = "\n\n" <> T.pack (symbolVal (Proxy @s))
|
|||||||
|
|
||||||
type CustomOpenApi = CustomJSON
|
type CustomOpenApi = CustomJSON
|
||||||
|
|
||||||
instance (OpenApiOptions xs, GToSchema (Rep x), Generic x, Typeable x, Typeable xs) => ToSchema (CustomJSON xs x) where
|
instance
|
||||||
|
(OpenApiOptionModifier xs, GToSchema (Rep x), Generic x, Typeable x, Typeable xs, Typeable k) =>
|
||||||
|
ToSchema (CustomJSON (xs :: k) x)
|
||||||
|
where
|
||||||
declareNamedSchema Proxy =
|
declareNamedSchema Proxy =
|
||||||
openApiSchemaModifier @xs <$> genericDeclareNamedSchema (openApiOptions @xs) (Proxy @x)
|
openApiSchemaModifier @xs
|
||||||
|
<$> genericDeclareNamedSchema (openApiOptionsModifier @xs defaultSchemaOptions) (Proxy @x)
|
||||||
|
|
||||||
|
class OpenApiOptionModifier x where
|
||||||
|
openApiOptionsModifier :: SchemaOptions -> SchemaOptions
|
||||||
|
openApiOptionsModifier = id
|
||||||
|
openApiSchemaModifier :: NamedSchema -> NamedSchema
|
||||||
|
openApiSchemaModifier = id
|
||||||
|
|
||||||
data DatatypeNameModifier t
|
data DatatypeNameModifier t
|
||||||
|
|
||||||
instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (DatatypeNameModifier f ': xs) where
|
instance (StringModifier f) => OpenApiOptionModifier (DatatypeNameModifier f) where
|
||||||
openApiOptions = (openApiOptions @xs) {datatypeNameModifier = getStringModifier @f}
|
openApiOptionsModifier o = o {datatypeNameModifier = getStringModifier @f}
|
||||||
|
|
||||||
instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
|
instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where
|
||||||
aesonOptions = aesonOptions @xs
|
aesonOptions = aesonOptions @xs
|
||||||
|
|
||||||
type family (++) (x :: [k]) (y :: [k]) :: [k] where
|
|
||||||
(++) '[] ys = ys
|
|
||||||
(++) (x ': xs) ys = xs ++ (x ': ys)
|
|
||||||
|
|
||||||
type family Extending (c :: * -> *) (ee :: [*]) :: * -> * where
|
|
||||||
Extending (CustomJSON a) ee = CustomJSON (a ++ ee)
|
|
||||||
|
|
||||||
-- deriving-aeson-based instances
|
-- deriving-aeson-based instances
|
||||||
|
|
||||||
class OpenApiOptions (xs :: [Type]) where
|
instance OpenApiOptionModifier UnwrapUnaryRecords where
|
||||||
openApiOptions :: SchemaOptions
|
openApiOptionsModifier o = o {unwrapUnaryRecords = True}
|
||||||
openApiSchemaModifier :: NamedSchema -> NamedSchema
|
|
||||||
openApiSchemaModifier = id
|
|
||||||
|
|
||||||
instance OpenApiOptions '[] where
|
instance OpenApiOptionModifier OmitNothingFields
|
||||||
openApiOptions = defaultSchemaOptions
|
|
||||||
|
|
||||||
instance OpenApiOptions xs => OpenApiOptions (UnwrapUnaryRecords ': xs) where
|
instance OpenApiOptionModifier RejectUnknownFields where
|
||||||
openApiOptions = (openApiOptions @xs) {unwrapUnaryRecords = True}
|
|
||||||
|
|
||||||
instance OpenApiOptions xs => OpenApiOptions (OmitNothingFields ': xs) where
|
|
||||||
openApiOptions = openApiOptions @xs
|
|
||||||
|
|
||||||
instance OpenApiOptions xs => OpenApiOptions (RejectUnknownFields ': xs) where
|
|
||||||
openApiOptions = openApiOptions @xs
|
|
||||||
openApiSchemaModifier = schema . additionalProperties .~ Just (AdditionalPropertiesAllowed False)
|
openApiSchemaModifier = schema . additionalProperties .~ Just (AdditionalPropertiesAllowed False)
|
||||||
|
|
||||||
instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (FieldLabelModifier f ': xs) where
|
instance StringModifier f => OpenApiOptionModifier (FieldLabelModifier f) where
|
||||||
openApiOptions = (openApiOptions @xs) {fieldLabelModifier = getStringModifier @f}
|
openApiOptionsModifier o = o {fieldLabelModifier = getStringModifier @f}
|
||||||
|
|
||||||
instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (ConstructorTagModifier f ': xs) where
|
instance StringModifier f => OpenApiOptionModifier (ConstructorTagModifier f) where
|
||||||
openApiOptions = (openApiOptions @xs) {constructorTagModifier = getStringModifier @f}
|
openApiOptionsModifier o = o {constructorTagModifier = getStringModifier @f}
|
||||||
|
|
||||||
instance
|
instance
|
||||||
(OpenApiOptions xs, TypeError ('Text "openapi3-deriving does not currently the `TagSingleConstructors` modifier.")) =>
|
TypeError ('Text "deriving-openapi3 does not currently the `TagSingleConstructors` modifier.") =>
|
||||||
OpenApiOptions (TagSingleConstructors ': xs)
|
OpenApiOptionModifier TagSingleConstructors
|
||||||
where
|
|
||||||
openApiOptions = undefined
|
|
||||||
|
|
||||||
instance OpenApiOptions xs => OpenApiOptions (NoAllNullaryToStringTag ': xs) where
|
instance OpenApiOptionModifier NoAllNullaryToStringTag where
|
||||||
openApiOptions = (openApiOptions @xs) {allNullaryToStringTag = False}
|
openApiOptionsModifier o = o {allNullaryToStringTag = False}
|
||||||
|
|
||||||
instance (KnownSymbol t, KnownSymbol c, OpenApiOptions xs) => OpenApiOptions (SumTaggedObject t c ': xs) where
|
instance (KnownSymbol t, KnownSymbol c) => OpenApiOptionModifier (SumTaggedObject t c) where
|
||||||
openApiOptions = (openApiOptions @xs) {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
|
openApiOptionsModifier o = o {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))}
|
||||||
|
|
||||||
instance (OpenApiOptions xs) => OpenApiOptions (SumUntaggedValue ': xs) where
|
instance OpenApiOptionModifier SumUntaggedValue where
|
||||||
openApiOptions = (openApiOptions @xs) {sumEncoding = A.UntaggedValue}
|
openApiOptionsModifier o = o {sumEncoding = A.UntaggedValue}
|
||||||
|
|
||||||
instance (OpenApiOptions xs) => OpenApiOptions (SumObjectWithSingleField ': xs) where
|
instance OpenApiOptionModifier SumObjectWithSingleField where
|
||||||
openApiOptions = (openApiOptions @xs) {sumEncoding = A.ObjectWithSingleField}
|
openApiOptionsModifier o = o {sumEncoding = A.ObjectWithSingleField}
|
||||||
|
|
||||||
instance (OpenApiOptions xs) => OpenApiOptions (SumTwoElemArray ': xs) where
|
instance OpenApiOptionModifier SumTwoElemArray where
|
||||||
openApiOptions = (openApiOptions @xs) {sumEncoding = A.TwoElemArray}
|
openApiOptionsModifier o = o {sumEncoding = A.TwoElemArray}
|
||||||
|
|
||||||
|
instance OpenApiOptionModifier '[]
|
||||||
|
|
||||||
|
instance (OpenApiOptionModifier x, OpenApiOptionModifier xs) => OpenApiOptionModifier (x ': xs) where
|
||||||
|
openApiOptionsModifier = openApiOptionsModifier @xs . openApiOptionsModifier @x
|
||||||
|
openApiSchemaModifier = openApiSchemaModifier @xs . openApiSchemaModifier @x
|
||||||
|
@ -1,7 +1,4 @@
|
|||||||
resolver: lts-18.21
|
resolver: lts-18.23
|
||||||
|
|
||||||
packages:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
|
||||||
extra-deps:
|
|
||||||
- openapi3-3.1.0
|
|
||||||
|
Loading…
Reference in New Issue
Block a user