From a7837a187ad6e87fb84ecf8accb3d0c4ae414682 Mon Sep 17 00:00:00 2001 From: iko Date: Fri, 28 Jan 2022 17:45:57 +0300 Subject: [PATCH] Rewrote everything and added doctests --- .github/workflows/build.yaml | 5 ++ package.yaml | 4 +- runDoctests.sh | 9 +++ src/Deriving/OpenApi.hs | 119 +++++++++++++++++++++-------------- stack.yaml | 5 +- 5 files changed, 90 insertions(+), 52 deletions(-) create mode 100755 runDoctests.sh diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 5809acd..e5a624c 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -47,6 +47,11 @@ jobs: run: | stack build + - name: doctests + shell: bash + run: | + ./runDoctests.sh + - name: Check Formatting shell: bash run: | diff --git a/package.yaml b/package.yaml index 36e5f6e..5962f9d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,7 +1,7 @@ name: deriving-openapi3 version: 0.1.0.0 synopsis: DerivingVia for OpenAPI 3 -description: See for more details. +description: DerivingVia for OpenAPI 3 maintainer: Ilya Kostyuchenko category: JSON, Generics, OpenAPI license: MIT @@ -42,6 +42,8 @@ default-extensions: - TypeFamilies - PolyKinds - OverloadedStrings + - DerivingStrategies + - DerivingVia flags: servant-description: description: Create instances for the 'Description' type from 'servant' diff --git a/runDoctests.sh b/runDoctests.sh new file mode 100755 index 0000000..0aeab4f --- /dev/null +++ b/runDoctests.sh @@ -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 '{}' \; diff --git a/src/Deriving/OpenApi.hs b/src/Deriving/OpenApi.hs index 61c165f..41ee075 100644 --- a/src/Deriving/OpenApi.hs +++ b/src/Deriving/OpenApi.hs @@ -1,18 +1,43 @@ {-# LANGUAGE CPP #-} {-# 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 ( CustomOpenApi, DatatypeNameModifier, ToSchema, module Deriving.Aeson, - Extending, ) where import Control.Lens import qualified Data.Aeson.Types as A -import Data.Kind import Data.OpenApi import Data.OpenApi.Internal.Schema import Data.Proxy @@ -21,6 +46,10 @@ import Deriving.Aeson import GHC.Generics import GHC.TypeLits +-- $setup +-- >>> import qualified Data.Yaml +-- >>> import qualified Data.ByteString.Char8 + #ifdef SERVANT_DESCRIPTION import Servant.API @@ -30,8 +59,7 @@ import qualified Data.Text as T instance (AesonOptions xs) => AesonOptions (Description f ': xs) where aesonOptions = aesonOptions @xs -instance (OpenApiOptions xs, KnownSymbol t) => OpenApiOptions (Description t ': xs) where - openApiOptions = openApiOptions @xs +instance KnownSymbol t => OpenApiOptionModifier (Description t) where openApiSchemaModifier = schema . description <>~ Just (toTextLine @t) toTextLine :: forall s. KnownSymbol s => Text @@ -41,68 +69,65 @@ toTextLine = "\n\n" <> T.pack (symbolVal (Proxy @s)) 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 = - 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 -instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (DatatypeNameModifier f ': xs) where - openApiOptions = (openApiOptions @xs) {datatypeNameModifier = getStringModifier @f} +instance (StringModifier f) => OpenApiOptionModifier (DatatypeNameModifier f) where + openApiOptionsModifier o = o {datatypeNameModifier = getStringModifier @f} instance (AesonOptions xs) => AesonOptions (DatatypeNameModifier f ': xs) where 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 -class OpenApiOptions (xs :: [Type]) where - openApiOptions :: SchemaOptions - openApiSchemaModifier :: NamedSchema -> NamedSchema - openApiSchemaModifier = id +instance OpenApiOptionModifier UnwrapUnaryRecords where + openApiOptionsModifier o = o {unwrapUnaryRecords = True} -instance OpenApiOptions '[] where - openApiOptions = defaultSchemaOptions +instance OpenApiOptionModifier OmitNothingFields -instance OpenApiOptions xs => OpenApiOptions (UnwrapUnaryRecords ': xs) 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 +instance OpenApiOptionModifier RejectUnknownFields where openApiSchemaModifier = schema . additionalProperties .~ Just (AdditionalPropertiesAllowed False) -instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (FieldLabelModifier f ': xs) where - openApiOptions = (openApiOptions @xs) {fieldLabelModifier = getStringModifier @f} +instance StringModifier f => OpenApiOptionModifier (FieldLabelModifier f) where + openApiOptionsModifier o = o {fieldLabelModifier = getStringModifier @f} -instance (StringModifier f, OpenApiOptions xs) => OpenApiOptions (ConstructorTagModifier f ': xs) where - openApiOptions = (openApiOptions @xs) {constructorTagModifier = getStringModifier @f} +instance StringModifier f => OpenApiOptionModifier (ConstructorTagModifier f) where + openApiOptionsModifier o = o {constructorTagModifier = getStringModifier @f} instance - (OpenApiOptions xs, TypeError ('Text "openapi3-deriving does not currently the `TagSingleConstructors` modifier.")) => - OpenApiOptions (TagSingleConstructors ': xs) - where - openApiOptions = undefined + TypeError ('Text "deriving-openapi3 does not currently the `TagSingleConstructors` modifier.") => + OpenApiOptionModifier TagSingleConstructors -instance OpenApiOptions xs => OpenApiOptions (NoAllNullaryToStringTag ': xs) where - openApiOptions = (openApiOptions @xs) {allNullaryToStringTag = False} +instance OpenApiOptionModifier NoAllNullaryToStringTag where + openApiOptionsModifier o = o {allNullaryToStringTag = False} -instance (KnownSymbol t, KnownSymbol c, OpenApiOptions xs) => OpenApiOptions (SumTaggedObject t c ': xs) where - openApiOptions = (openApiOptions @xs) {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))} +instance (KnownSymbol t, KnownSymbol c) => OpenApiOptionModifier (SumTaggedObject t c) where + openApiOptionsModifier o = o {sumEncoding = A.TaggedObject (symbolVal (Proxy @t)) (symbolVal (Proxy @c))} -instance (OpenApiOptions xs) => OpenApiOptions (SumUntaggedValue ': xs) where - openApiOptions = (openApiOptions @xs) {sumEncoding = A.UntaggedValue} +instance OpenApiOptionModifier SumUntaggedValue where + openApiOptionsModifier o = o {sumEncoding = A.UntaggedValue} -instance (OpenApiOptions xs) => OpenApiOptions (SumObjectWithSingleField ': xs) where - openApiOptions = (openApiOptions @xs) {sumEncoding = A.ObjectWithSingleField} +instance OpenApiOptionModifier SumObjectWithSingleField where + openApiOptionsModifier o = o {sumEncoding = A.ObjectWithSingleField} -instance (OpenApiOptions xs) => OpenApiOptions (SumTwoElemArray ': xs) where - openApiOptions = (openApiOptions @xs) {sumEncoding = A.TwoElemArray} +instance OpenApiOptionModifier SumTwoElemArray where + 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 diff --git a/stack.yaml b/stack.yaml index 22f42ee..ee1b2fa 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,4 @@ -resolver: lts-18.21 +resolver: lts-18.23 packages: - . - -extra-deps: - - openapi3-3.1.0