Use prefixItems for tuples

.gitignore

@@ -17,3 +17,4 @@ cabal.sandbox.config
 *.aux
 *.hp
 .stack-work/
+stack.yaml.lock

openapi3.cabal

@@ -83,19 +83,19 @@ library
     , aeson                     >=1.4.2.0  && <1.6 || >=2.0.1.0 && < 2.3
     , aeson-pretty              >=0.8.7    && <0.9
     -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
-    , cookie                    >=0.4.3    && <0.5
+    , cookie                    >=0.4.3    && <0.6
     , generics-sop              >=0.5.1.0  && <0.6
     , hashable                  >=1.2.7.0  && <1.5
     , http-media                >=0.8.0.0  && <0.9
     , insert-ordered-containers >=0.2.3    && <0.3
-    , lens                      >=4.16.1   && <5.3
+    , lens                      >=4.16.1   && <5.4
     , optics-core               >=0.2      && <0.5
     , optics-th                 >=0.2      && <0.5
     , scientific                >=0.3.6.2  && <0.4
     , unordered-containers      >=0.2.9.0  && <0.3
     , uuid-types                >=1.0.3    && <1.1
     , vector                    >=0.12.0.1 && <0.14
-    , QuickCheck                >=2.10.1   && <2.15
+    , QuickCheck                >=2.10.1   && <2.16
 
   default-language:    Haskell2010
 

src/Data/OpenApi.hs

@@ -30,7 +30,6 @@ module Data.OpenApi (
 
   -- * Re-exports
   module Data.OpenApi.Lens,
-  module Data.OpenApi.Optics,
   module Data.OpenApi.Operation,
   module Data.OpenApi.ParamSchema,
   module Data.OpenApi.Schema,
@@ -76,6 +75,7 @@ module Data.OpenApi (
   Schema(..),
   NamedSchema(..),
   OpenApiItems(..),
+  OpenApiPrefixItems(..),
   Xml(..),
   Pattern,
   AdditionalProperties(..),

src/Data/OpenApi/Declare.hs

@@ -52,7 +52,7 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
     return (mappend d' d'', f x)
 
 instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
-  return x = DeclareT (\_ -> pure (mempty, x))
+  return = pure
   DeclareT dx >>= f = DeclareT $ \d -> do
     ~(d',  x) <- dx d
     ~(d'', y) <- runDeclareT (f x) (mappend d d')

src/Data/OpenApi/Internal.hs

@@ -14,6 +14,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Data.OpenApi.Internal where
 
 import Prelude ()
@@ -335,7 +337,9 @@ instance Data MediaType where
 
   dataTypeOf _ = mediaTypeData
 
+mediaTypeConstr :: Constr
 mediaTypeConstr = mkConstr mediaTypeData "MediaType" [] Prefix
+mediaTypeData :: DataType
 mediaTypeData = mkDataType "MediaType" [mediaTypeConstr]
 
 instance Hashable MediaType where
@@ -599,6 +603,10 @@ data OpenApiItems where
   OpenApiItemsArray     :: [Referenced Schema] -> OpenApiItems
   deriving (Eq, Show, Typeable, Data)
 
+data OpenApiPrefixItems where
+  OpenApiPrefixItemsArray :: [Referenced Schema] -> OpenApiPrefixItems
+  deriving (Eq, Show, Typeable, Data)
+
 data OpenApiType where
   OpenApiString   :: OpenApiType
   OpenApiNumber   :: OpenApiType
@@ -661,6 +669,7 @@ data Schema = Schema
   , _schemaType :: Maybe OpenApiType
   , _schemaFormat :: Maybe Format
   , _schemaItems :: Maybe OpenApiItems
+  , _schemaPrefixItems :: Maybe OpenApiPrefixItems
   , _schemaMaximum :: Maybe Scientific
   , _schemaExclusiveMaximum :: Maybe Bool
   , _schemaMinimum :: Maybe Scientific
@@ -1006,12 +1015,12 @@ deriveGeneric ''OpenApiSpecVersion
 -- =======================================================================
 
 instance Semigroup OpenApiSpecVersion where
-  (<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b 
-  
+  (<>) (OpenApiSpecVersion a) (OpenApiSpecVersion b) = OpenApiSpecVersion $ max a b
+
 instance Monoid OpenApiSpecVersion where
   mempty = OpenApiSpecVersion (makeVersion [3,0,0])
   mappend = (<>)
-  
+
 instance Semigroup OpenApi where
   (<>) = genericMappend
 instance Monoid OpenApi where
@@ -1282,7 +1291,7 @@ instance FromJSON OAuth2AuthorizationCodeFlow where
 -- Manual ToJSON instances
 -- =======================================================================
 
-instance ToJSON OpenApiSpecVersion where 
+instance ToJSON OpenApiSpecVersion where
   toJSON (OpenApiSpecVersion v)= toJSON . showVersion $ v
 
 instance ToJSON MediaType where
@@ -1371,6 +1380,14 @@ instance ToJSON OpenApiItems where
     ]
   toJSON (OpenApiItemsArray  x) = object [ "items" .= x ]
 
+instance ToJSON OpenApiPrefixItems where
+  toJSON (OpenApiPrefixItemsArray []) = object
+    [ "prefixItems" .= object []
+    , "maxItems" .= (0 :: Int)
+    , "example" .= Array mempty
+    ]
+  toJSON (OpenApiPrefixItemsArray x) = object [ "prefixItems" .= x ]
+
 instance ToJSON Components where
   toJSON = sopSwaggerGenericToJSON
   toEncoding = sopSwaggerGenericToEncoding
@@ -1456,15 +1473,15 @@ instance FromJSON OpenApiSpecVersion where
   parseJSON = withText "OpenApiSpecVersion" $ \str ->
             let validatedVersion :: Either String Version
                 validatedVersion = do
-                  parsedVersion <- readVersion str 
+                  parsedVersion <- readVersion str
                   unless ((parsedVersion >= lowerOpenApiSpecVersion) && (parsedVersion <= upperOpenApiSpecVersion)) $
                      Left ("The provided version " <> showVersion parsedVersion <> " is out of the allowed range >=" <> showVersion lowerOpenApiSpecVersion <> " && <=" <> showVersion upperOpenApiSpecVersion)
                   return parsedVersion
-             in 
+             in
               either fail (return . OpenApiSpecVersion) validatedVersion
     where
     readVersion :: Text -> Either String Version
-    readVersion v = case readP_to_S parseVersion (Text.unpack v) of 
+    readVersion v = case readP_to_S parseVersion (Text.unpack v) of
       [] -> Left $ "Failed to parse as a version string " <> Text.unpack v
       solutions -> Right (fst . last $ solutions)
 
@@ -1526,6 +1543,10 @@ instance FromJSON OpenApiItems where
   parseJSON js@(Array _)  = OpenApiItemsArray  <$> parseJSON js
   parseJSON _ = empty
 
+instance FromJSON OpenApiPrefixItems where
+  parseJSON js@(Array _) = OpenApiPrefixItemsArray <$> parseJSON js
+  parseJSON _ = empty
+
 instance FromJSON Components where
   parseJSON = sopSwaggerGenericParseJSON
 
@@ -1649,7 +1670,7 @@ instance HasSwaggerAesonOptions Encoding where
 instance HasSwaggerAesonOptions Link where
   swaggerAesonOptions _ = mkSwaggerAesonOptions "link"
 
-instance AesonDefaultValue Version where 
+instance AesonDefaultValue Version where
   defaultValue = Just (makeVersion [3,0,0])
 instance AesonDefaultValue OpenApiSpecVersion
 instance AesonDefaultValue Server

src/Data/OpenApi/Internal/AesonUtils.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 module Data.OpenApi.Internal.AesonUtils (
     -- * Generic functions

src/Data/OpenApi/Internal/ParamSchema.hs

@@ -19,6 +19,7 @@ module Data.OpenApi.Internal.ParamSchema where
 
 import Control.Lens
 import Data.Aeson (ToJSON (..))
+import Data.Kind
 import Data.Proxy
 import GHC.Generics
 
@@ -163,7 +164,7 @@ instance ToParamSchema Word64 where
 --     "minimum": -128,
 --     "type": "integer"
 -- }
-toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> Schema
+toParamSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
 toParamSchemaBoundedIntegral _ = mempty
   & type_ ?~ OpenApiInteger
   & minimum_ ?~ fromInteger (toInteger (minBound :: a))
@@ -310,10 +311,10 @@ instance ToParamSchema UUID where
 --     ],
 --     "type": "string"
 -- }
-genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
+genericToParamSchema :: forall a. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> Schema
 genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
 
-class GToParamSchema (f :: * -> *) where
+class GToParamSchema (f :: Type -> Type) where
   gtoParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
 
 instance GToParamSchema f => GToParamSchema (D1 d f) where
@@ -331,7 +332,7 @@ instance ToParamSchema c => GToParamSchema (K1 i c) where
 instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where
   gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
 
-class GEnumParamSchema (f :: * -> *) where
+class GEnumParamSchema (f :: Type -> Type) where
   genumParamSchema :: SchemaOptions -> Proxy f -> Schema -> Schema
 
 instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where

src/Data/OpenApi/Internal/Schema.hs

@@ -24,7 +24,7 @@ module Data.OpenApi.Internal.Schema where
 import Prelude ()
 import Prelude.Compat
 
-import Control.Lens hiding (allOf)
+import Control.Lens hiding (allOf, anyOf)
 import Data.Data.Lens (template)
 
 import Control.Applicative ((<|>))
@@ -43,6 +43,7 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Int
 import Data.IntSet (IntSet)
 import Data.IntMap (IntMap)
+import Data.Kind
 import Data.List (sort)
 import Data.List.NonEmpty.Compat (NonEmpty)
 import Data.Map (Map)
@@ -345,7 +346,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
 --         2,
 --         3
 --     ],
---     "items": {
+--     "prefixItems": {
 --         "type": "number"
 --     },
 --     "type": "array"
@@ -357,7 +358,7 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
 --         "Jack",
 --         25
 --     ],
---     "items": [
+--     "prefixItems": [
 --         {
 --             "type": "string"
 --         },
@@ -406,6 +407,7 @@ sketchSchema = sketch . toJSON
       & items ?~ case ischema of
           Just s -> OpenApiItemsObject (Inline s)
           _      -> OpenApiItemsArray (map Inline ys)
+      & prefixItems ?~ OpenApiPrefixItemsArray (map Inline ys)
       where
         ys = map go (V.toList xs)
         allSame = and ((zipWith (==)) ys (tail ys))
@@ -572,6 +574,7 @@ sketchStrictSchema = go . toJSON
       & maxItems    ?~ fromIntegral sz
       & minItems    ?~ fromIntegral sz
       & items       ?~ OpenApiItemsArray (map (Inline . go) (V.toList xs))
+      & prefixItems ?~ OpenApiPrefixItemsArray (map (Inline . go) (V.toList xs))
       & uniqueItems ?~ allUnique
       & enum_       ?~ [js]
       where
@@ -587,7 +590,7 @@ sketchStrictSchema = go . toJSON
       where
         names = objectKeys o
 
-class GToSchema (f :: * -> *) where
+class GToSchema (f :: Type -> Type) where
   gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
 
 instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
@@ -623,7 +626,10 @@ instance ToSchema Float       where declareNamedSchema = plain . paramSchemaToSc
 instance (Typeable (Fixed a), HasResolution a) => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
 
 instance ToSchema a => ToSchema (Maybe a) where
-  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
+  declareNamedSchema _ = do
+    ref <- declareSchemaRef (Proxy @a)
+    -- NB: using 'oneOf' goes wrong for nested Maybe's as both subschemas match 'null'.
+    pure $ unnamed $ mempty & anyOf ?~ [Inline $ mempty & type_ ?~ OpenApiNull, ref]
 
 instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where
   -- To match Aeson instance
@@ -988,6 +994,10 @@ appendItem x Nothing = Just (OpenApiItemsArray [x])
 appendItem x (Just (OpenApiItemsArray xs)) = Just (OpenApiItemsArray (xs ++ [x]))
 appendItem _ _ = error "GToSchema.appendItem: cannot append to OpenApiItemsObject"
 
+appendPrefixItem :: Referenced Schema -> Maybe OpenApiPrefixItems -> Maybe OpenApiPrefixItems
+appendPrefixItem x Nothing = Just (OpenApiPrefixItemsArray [x])
+appendPrefixItem x (Just (OpenApiPrefixItemsArray xs)) = Just (OpenApiPrefixItemsArray (xs ++ [x]))
+
 withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
   SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
 withFieldSchema opts _ isRequiredField schema = do
@@ -1016,10 +1026,7 @@ instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (
 instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
   gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
 
-instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
-  gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
-
-instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
+instance ToSchema c => GToSchema (K1 i c) where
   gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
 
 instance ( GSumToSchema f
@@ -1031,7 +1038,9 @@ instance ( GSumToSchema f
 
 gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
 gdeclareNamedSumSchema opts proxy _
-  | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchemas)
+  | allNullaryToStringTag opts && allNullary = pure $ unnamed $ mempty
+      & type_ ?~ OpenApiString
+      & enum_ ?~ map (String . fst) sumSchemas
   | otherwise = do
     (schemas, _) <- runWriterT declareSumSchema
     return $ unnamed $ mempty
@@ -1040,13 +1049,9 @@ gdeclareNamedSumSchema opts proxy _
     declareSumSchema = gsumToSchema opts proxy
     (sumSchemas, All allNullary) = undeclare (runWriterT declareSumSchema)
 
-    toStringTag schemas = mempty
-      & type_ ?~ OpenApiString
-      & enum_ ?~ map (String . fst) sumSchemas
-
 type AllNullary = All
 
-class GSumToSchema (f :: * -> *)  where
+class GSumToSchema (f :: Type -> Type)  where
   gsumToSchema :: SchemaOptions -> Proxy f -> WriterT AllNullary (Declare (Definitions Schema)) [(T.Text, Referenced Schema)]
 
 instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

src/Data/OpenApi/Internal/TypeShape.hs

@@ -3,9 +3,11 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 module Data.OpenApi.Internal.TypeShape where
 
+import Data.Kind
 import Data.Proxy
 import GHC.Generics
 import GHC.TypeLits
@@ -46,7 +48,7 @@ type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint
       )
 
 -- | Infer a 'TypeShape' for a generic representation of a type.
-type family GenericShape (g :: * -> *) :: TypeShape
+type family GenericShape (g :: Type -> Type) :: TypeShape
 
 type instance GenericShape (f :*: g)        = ProdCombine  (GenericShape f) (GenericShape g)
 type instance GenericShape (f :+: g)        = SumCombine   (GenericShape f) (GenericShape g)

src/Data/OpenApi/Lens.hs

@@ -115,6 +115,12 @@ instance
   => HasItems s (Maybe OpenApiItems) where
   items = schema.items
 
+instance
+  {-# OVERLAPPABLE #-}
+  HasSchema s Schema
+  => HasPrefixItems s (Maybe OpenApiPrefixItems) where
+  prefixItems = schema.prefixItems
+
 instance
   {-# OVERLAPPABLE #-}
   HasSchema s Schema