Skip to content

Commit 1300fc1

Browse files
rasheedjastevladimir
rasheedja
and
stevladimir
authored
Maybe schema (#2)
* Use GHC-9.4.8 snapshot and fix few warnings * gitignore stack.yaml.lock * Fix schema for Maybe * Use 'anyOf' instead of 'oneOf' to fix nested Maybe's * Fix copy-pasta --------- Co-authored-by: Uladzimir Stsepchanka <st.uladzimir@protonmail.com>
1 parent 89825c4 commit 1300fc1

15 files changed

Lines changed: 113 additions & 55 deletions

File tree

‎.gitignore‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,3 +17,4 @@ cabal.sandbox.config
1717
*.aux
1818
*.hp
1919
.stack-work/
20+
stack.yaml.lock

‎src/Data/OpenApi.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,6 @@ module Data.OpenApi (
3030

3131
-- * Re-exports
3232
module Data.OpenApi.Lens,
33-
module Data.OpenApi.Optics,
3433
module Data.OpenApi.Operation,
3534
module Data.OpenApi.ParamSchema,
3635
module Data.OpenApi.Schema,

‎src/Data/OpenApi/Declare.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
5252
return (mappend d' d'', f x)
5353

5454
instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
55-
return x = DeclareT (\_ -> pure (mempty, x))
55+
return = pure
5656
DeclareT dx >>= f = DeclareT $ \d -> do
5757
~(d', x) <- dx d
5858
~(d'', y) <- runDeclareT (f x) (mappend d d')

‎src/Data/OpenApi/Internal.hs‎

Lines changed: 12 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@
1414
{-# LANGUAGE TemplateHaskell #-}
1515
{-# LANGUAGE TypeFamilies #-}
1616
{-# LANGUAGE UndecidableInstances #-}
17+
{-# OPTIONS_GHC -fno-warn-orphans #-}
18+
1719
module Data.OpenApi.Internal where
1820

1921
import Prelude ()
@@ -335,7 +337,9 @@ instance Data MediaType where
335337

336338
dataTypeOf _ = mediaTypeData
337339

340+
mediaTypeConstr :: Constr
338341
mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix
342+
mediaTypeData :: DataType
339343
mediaTypeData = mkDataType "MediaType" [mediaTypeConstr]
340344

341345
instance Hashable MediaType where
@@ -1006,12 +1010,12 @@ deriveGeneric ''OpenApiSpecVersion
10061010
-- =======================================================================
10071011

10081012
instance Semigroup OpenApiSpecVersion where
1009-
(<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b
1010-
1013+
(<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b
1014+
10111015
instance Monoid OpenApiSpecVersion where
10121016
mempty = OpenApiSpecVersion (makeVersion [3,0,0])
10131017
mappend = (<>)
1014-
1018+
10151019
instance Semigroup OpenApi where
10161020
(<>) = genericMappend
10171021
instance Monoid OpenApi where
@@ -1282,7 +1286,7 @@ instance FromJSON OAuth2AuthorizationCodeFlow where
12821286
-- Manual ToJSON instances
12831287
-- =======================================================================
12841288

1285-
instance ToJSON OpenApiSpecVersion where
1289+
instance ToJSON OpenApiSpecVersion where
12861290
toJSON (OpenApiSpecVersion v)= toJSON . showVersion $ v
12871291

12881292
instance ToJSON MediaType where
@@ -1456,15 +1460,15 @@ instance FromJSON OpenApiSpecVersion where
14561460
parseJSON = withText "OpenApiSpecVersion" $ \str ->
14571461
let validatedVersion :: Either String Version
14581462
validatedVersion = do
1459-
parsedVersion <- readVersion str
1463+
parsedVersion <- readVersion str
14601464
unless ((parsedVersion >= lowerOpenApiSpecVersion) && (parsedVersion <= upperOpenApiSpecVersion)) $
14611465
Left ("The provided version " <> showVersion parsedVersion <> " is out of the allowed range >=" <> showVersion lowerOpenApiSpecVersion <> " && <=" <> showVersion upperOpenApiSpecVersion)
14621466
return parsedVersion
1463-
in
1467+
in
14641468
either fail (return . OpenApiSpecVersion) validatedVersion
14651469
where
14661470
readVersion :: Text -> Either String Version
1467-
readVersion v = case readP_to_S parseVersion (Text.unpack v) of
1471+
readVersion v = case readP_to_S parseVersion (Text.unpack v) of
14681472
[] -> Left $ "Failed to parse as a version string " <> Text.unpack v
14691473
solutions -> Right (fst . last $ solutions)
14701474

@@ -1649,7 +1653,7 @@ instance HasSwaggerAesonOptions Encoding where
16491653
instance HasSwaggerAesonOptions Link where
16501654
swaggerAesonOptions _ = mkSwaggerAesonOptions "link"
16511655

1652-
instance AesonDefaultValue Version where
1656+
instance AesonDefaultValue Version where
16531657
defaultValue = Just (makeVersion [3,0,0])
16541658
instance AesonDefaultValue OpenApiSpecVersion
16551659
instance AesonDefaultValue Server

‎src/Data/OpenApi/Internal/AesonUtils.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE ScopedTypeVariables #-}
55
{-# LANGUAGE ExplicitForAll #-}
66
{-# LANGUAGE TemplateHaskell #-}
7+
{-# LANGUAGE TypeOperators #-}
78
{-# LANGUAGE UndecidableSuperClasses #-}
89
module Data.OpenApi.Internal.AesonUtils (
910
-- * Generic functions

‎src/Data/OpenApi/Internal/ParamSchema.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Data.OpenApi.Internal.ParamSchema where
1919

2020
import Control.Lens
2121
import Data.Aeson (ToJSON (..))
22+
import Data.Kind
2223
import Data.Proxy
2324
import GHC.Generics
2425

@@ -163,7 +164,7 @@ instance ToParamSchema Word64 where
163164
-- "minimum": -128,
164165
-- "type": "integer"
165166
-- }
166-
toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema
167+
toParamSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
167168
toParamSchemaBoundedIntegral _ = mempty
168169
& type_ ?~ OpenApiInteger
169170
& minimum_ ?~ fromInteger (toInteger (minBound :: a))
@@ -310,10 +311,10 @@ instance ToParamSchema UUID where
310311
-- ],
311312
-- "type": "string"
312313
-- }
313-
genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
314+
genericToParamSchema :: forall a. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
314315
genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
315316

316-
class GToParamSchema (f :: * -> *) where
317+
class GToParamSchema (f :: Type -> Type) where
317318
gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
318319

319320
instance GToParamSchema f => GToParamSchema (D1 d f) where
@@ -331,7 +332,7 @@ instance ToParamSchema c => GToParamSchema (K1 i c) where
331332
instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where
332333
gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
333334

334-
class GEnumParamSchema (f :: * -> *) where
335+
class GEnumParamSchema (f :: Type -> Type) where
335336
genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
336337

337338
instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where

‎src/Data/OpenApi/Internal/Schema.hs‎

Lines changed: 12 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@ module Data.OpenApi.Internal.Schema where
2424
import Prelude ()
2525
import Prelude.Compat
2626

27-
import Control.Lens hiding (allOf)
27+
import Control.Lens hiding (allOf, anyOf)
2828
import Data.Data.Lens (template)
2929

3030
import Control.Applicative ((<|>))
@@ -43,6 +43,7 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4343
import Data.Int
4444
import Data.IntSet (IntSet)
4545
import Data.IntMap (IntMap)
46+
import Data.Kind
4647
import Data.List (sort)
4748
import Data.List.NonEmpty.Compat (NonEmpty)
4849
import Data.Map (Map)
@@ -587,7 +588,7 @@ sketchStrictSchema = go . toJSON
587588
where
588589
names = objectKeys o
589590

590-
class GToSchema (f :: * -> *) where
591+
class GToSchema (f :: Type -> Type) where
591592
gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
592593

593594
instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
@@ -623,7 +624,10 @@ instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSc
623624
instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
624625

625626
instance ToSchema a => ToSchema (Maybe a) where
626-
declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
627+
declareNamedSchema _ = do
628+
ref <- declareSchemaRef (Proxy @a)
629+
-- NB: using 'oneOf' goes wrong for nested Maybe's as both subschemas match 'null'.
630+
pure $ unnamed $ mempty & anyOf ?~ [Inline $ mempty & type_ ?~ OpenApiNull, ref]
627631

628632
instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
629633
-- To match Aeson instance
@@ -1016,10 +1020,7 @@ instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (
10161020
instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
10171021
gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
10181022

1019-
instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
1020-
gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
1021-
1022-
instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
1023+
instance ToSchema c => GToSchema (K1 i c) where
10231024
gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
10241025

10251026
instance ( GSumToSchema f
@@ -1031,7 +1032,9 @@ instance ( GSumToSchema f
10311032

10321033
gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
10331034
gdeclareNamedSumSchema opts proxy _
1034-
| allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas)
1035+
| allNullaryToStringTag opts && allNullary = pure $ unnamed $ mempty
1036+
& type_ ?~ OpenApiString
1037+
& enum_ ?~ map (String . fst) sumSchemas
10351038
| otherwise = do
10361039
(schemas, _) <- runWriterT declareSumSchema
10371040
return $ unnamed $ mempty
@@ -1040,13 +1043,9 @@ gdeclareNamedSumSchema opts proxy _
10401043
declareSumSchema = gsumToSchema opts proxy
10411044
(sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)
10421045

1043-
toStringTag schemas = mempty
1044-
& type_ ?~ OpenApiString
1045-
& enum_ ?~ map (String . fst) sumSchemas
1046-
10471046
type AllNullary = All
10481047

1049-
class GSumToSchema (f :: * -> *) where
1048+
class GSumToSchema (f :: Type -> Type) where
10501049
gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]
10511050

10521051
instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

‎src/Data/OpenApi/Internal/TypeShape.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,9 +3,11 @@
33
{-# LANGUAGE TypeFamilies #-}
44
{-# LANGUAGE TypeOperators #-}
55
{-# LANGUAGE UndecidableInstances #-}
6+
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
67

78
module Data.OpenApi.Internal.TypeShape where
89

10+
import Data.Kind
911
import Data.Proxy
1012
import GHC.Generics
1113
import GHC.TypeLits
@@ -46,7 +48,7 @@ type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint
4648
)
4749

4850
-- | Infer a 'TypeShape' for a generic representation of a type.
49-
type family GenericShape (g :: * -> *) :: TypeShape
51+
type family GenericShape (g :: Type -> Type) :: TypeShape
5052

5153
type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
5254
type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)

‎src/Data/OpenApi/Optics.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE OverloadedLabels #-}
55
{-# LANGUAGE TemplateHaskell #-}
66
{-# LANGUAGE TypeFamilies #-}
7+
{-# LANGUAGE TypeOperators #-}
78
{-# LANGUAGE UndecidableInstances #-}
89
{-# OPTIONS_GHC -fno-warn-orphans #-}
910
-- |

‎src/Data/OpenApi/Schema/Generator.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,8 @@ schemaGen _ schema
3434
| Just cases <- schema ^. enum_ = elements cases
3535
schemaGen defns schema
3636
| Just variants <- schema ^. oneOf = schemaGen defns =<< elements (dereference defns <$> variants)
37+
schemaGen defns schema
38+
| Just variants <- schema ^. anyOf = schemaGen defns =<< elements (dereference defns <$> variants)
3739
schemaGen defns schema =
3840
case schema ^. type_ of
3941
Nothing ->

0 commit comments

Comments
 (0)