Merge pull request #24 from GetShopTV/swagger-items

Introduce SwaggerItems GADT to simplify ParamSchema

src/Data/Swagger.hs

@@ -45,7 +45,7 @@ module Data.Swagger (
   -- * Schemas
   ParamSchema(..),
   Schema(..),
-  SchemaItems(..),
+  SwaggerItems(..),
   Xml(..),
 
   -- * Responses

src/Data/Swagger/Internal.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Data.Swagger.Internal where
 
 import           Control.Applicative
@@ -324,9 +325,33 @@ data ParamOtherSchema = ParamOtherSchema
     -- Default value is csv.
   , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)
 
-  , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items
+  , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
   } deriving (Eq, Show, Generic, Data, Typeable)
 
+data SwaggerItems t where
+  SwaggerItemsPrimitive :: Items               -> SwaggerItems t
+  SwaggerItemsObject    :: Referenced Schema   -> SwaggerItems Schema
+  SwaggerItemsArray     :: [Referenced Schema] -> SwaggerItems Schema
+
+deriving instance Eq (SwaggerItems t)
+deriving instance Show (SwaggerItems t)
+deriving instance Typeable (SwaggerItems t)
+
+swaggerItemsPrimitiveConstr :: Constr
+swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
+
+swaggerItemsDataType :: DataType
+swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
+
+instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerItems t) where
+  gunfold k z c = case constrIndex c of
+    1 -> k (z SwaggerItemsPrimitive)
+    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
+  toConstr _ = swaggerItemsPrimitiveConstr
+  dataTypeOf _ = swaggerItemsDataType
+
+deriving instance Data (SwaggerItems Schema)
+
 data SwaggerType t where
   SwaggerString   :: SwaggerType t
   SwaggerNumber   :: SwaggerType t
@@ -453,15 +478,10 @@ data Schema = Schema
   , _schemaMaxProperties :: Maybe Integer
   , _schemaMinProperties :: Maybe Integer
 
-  , _schemaParamSchema :: ParamSchema Schema SchemaItems
+  , _schemaParamSchema :: ParamSchema Schema
   } deriving (Eq, Show, Generic, Data, Typeable)
 
-data SchemaItems
-  = SchemaItemsObject (Referenced Schema)
-  | SchemaItemsArray [Referenced Schema]
-  deriving (Eq, Show, Generic, Data, Typeable)
-
-data ParamSchema t items = ParamSchema
+data ParamSchema t = ParamSchema
   { -- | Declares the value of the parameter that the server will use if none is provided,
     -- for example a @"count"@ to control the number of results per page might default to @100@
     -- if not supplied by the client in the request.
@@ -471,7 +491,7 @@ data ParamSchema t items = ParamSchema
 
   , _paramSchemaType :: SwaggerType t
   , _paramSchemaFormat :: Maybe Format
-  , _paramSchemaItems :: Maybe items
+  , _paramSchemaItems :: Maybe (SwaggerItems t)
   , _paramSchemaMaximum :: Maybe Scientific
   , _paramSchemaExclusiveMaximum :: Maybe Bool
   , _paramSchemaMinimum :: Maybe Scientific
@@ -486,7 +506,7 @@ data ParamSchema t items = ParamSchema
   , _paramSchemaMultipleOf :: Maybe Scientific
   } deriving (Eq, Show, Generic, Typeable)
 
-deriving instance (Data t, Data (SwaggerType t), Data i) => Data (ParamSchema t i)
+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
 
 data Xml = Xml
   { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -521,7 +541,7 @@ data Items = Items
     -- Default value is @'ItemsCollectionCSV'@.
     _itemsCollectionFormat :: Maybe (CollectionFormat Items)
 
-  , _itemsParamSchema :: ParamSchema Items Items
+  , _itemsParamSchema :: ParamSchema Items
   } deriving (Eq, Show, Generic, Data, Typeable)
 
 -- | A container for the expected responses of an operation.
@@ -571,7 +591,7 @@ data Header = Header
     -- Default value is @'ItemsCollectionCSV'@.
   , _headerCollectionFormat :: Maybe (CollectionFormat Items)
 
-  , _headerParamSchema :: ParamSchema Header Items
+  , _headerParamSchema :: ParamSchema Header
   } deriving (Eq, Show, Generic, Data, Typeable)
 
 data Example = Example { getExample :: Map MediaType Value }
@@ -706,7 +726,7 @@ instance Monoid Schema where
   mempty = genericMempty
   mappend = genericMappend
 
-instance Monoid (ParamSchema t i) where
+instance Monoid (ParamSchema t) where
   mempty = genericMempty
   mappend = genericMappend
 
@@ -742,7 +762,7 @@ instance SwaggerMonoid Info
 instance SwaggerMonoid Paths
 instance SwaggerMonoid PathItem
 instance SwaggerMonoid Schema
-instance SwaggerMonoid (ParamSchema t i)
+instance SwaggerMonoid (ParamSchema t)
 instance SwaggerMonoid Param
 instance SwaggerMonoid ParamOtherSchema
 instance SwaggerMonoid Responses
@@ -870,6 +890,11 @@ instance ToJSON Header where
 instance ToJSON Items where
   toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "items")
 
+instance ToJSON (SwaggerItems t) where
+  toJSON (SwaggerItemsPrimitive x) = toJSON x
+  toJSON (SwaggerItemsObject    x) = toJSON x
+  toJSON (SwaggerItemsArray     x) = toJSON x
+
 instance ToJSON Host where
   toJSON (Host host mport) = toJSON $
     case mport of
@@ -892,10 +917,6 @@ instance ToJSON ParamAnySchema where
 instance ToJSON ParamOtherSchema where
   toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
 
-instance ToJSON SchemaItems where
-  toJSON (SchemaItemsObject x) = toJSON x
-  toJSON (SchemaItemsArray xs) = toJSON xs
-
 instance ToJSON Responses where
   toJSON (Responses def rs) = omitEmpties $
     toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
@@ -940,7 +961,7 @@ instance ToJSON (CollectionFormat t) where
   toJSON CollectionPipes = "pipes"
   toJSON CollectionMulti = "multi"
 
-instance ToJSON i => ToJSON (ParamSchema t i) where
+instance ToJSON (ParamSchema t) where
   toJSON = genericToJSON (jsonPrefix "paramSchema")
 
 -- =======================================================================
@@ -1003,6 +1024,14 @@ instance FromJSON Header where
 instance FromJSON Items where
   parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items")
 
+instance {-# OVERLAPPABLE #-} FromJSON (SwaggerItems t) where
+  parseJSON js = SwaggerItemsPrimitive <$> parseJSON js
+
+instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where
+  parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
+  parseJSON js@(Array _)  = SwaggerItemsArray  <$> parseJSON js
+  parseJSON _ = empty
+
 instance FromJSON Host where
   parseJSON (String s) =
     case fromInteger <$> readMaybe portStr of
@@ -1035,11 +1064,6 @@ instance FromJSON ParamAnySchema where
 instance FromJSON ParamOtherSchema where
   parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
 
-instance FromJSON SchemaItems where
-  parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js
-  parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js
-  parseJSON _ = empty
-
 instance FromJSON Responses where
   parseJSON (Object o) = Responses
     <$> o .:? "default"
@@ -1101,8 +1125,10 @@ instance FromJSON (CollectionFormat Param) where
 instance FromJSON (CollectionFormat Items) where
   parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
 
--- NOTE: The constraint @FromJSON (SwaggerType t)@ is necessary here!
+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
+-- @FromJSON (SwaggerItems t)@ are necessary here!
 -- Without the constraint the general instance will be used
--- that only accepts common types (i.e. NOT object, null or file).
-instance (FromJSON (SwaggerType t), FromJSON i) => FromJSON (ParamSchema t i) where
+-- that only accepts common types (i.e. NOT object, null or file)
+-- and primitive array items.
+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
   parseJSON = genericParseJSON (jsonPrefix "ParamSchema")

src/Data/Swagger/Internal/ParamSchema.hs

@@ -63,8 +63,8 @@ import Data.Swagger.SchemaOptions
 -- @
 class ToParamSchema a where
   -- | Convert a type into a plain parameter schema.
-  toParamSchema :: proxy a -> ParamSchema t i
-  default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t i
+  toParamSchema :: proxy a -> ParamSchema t
+  default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
   toParamSchema = genericToParamSchema defaultSchemaOptions
 
 instance {-# OVERLAPPING #-} ToParamSchema String where
@@ -89,7 +89,7 @@ instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
 instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
 
 -- | Default plain schema for @'Bounded'@, @'Integral'@ types.
-toParamSchemaBoundedIntegral :: forall proxy a t i. (Bounded a, Integral a) => proxy a -> ParamSchema t i
+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
 toParamSchemaBoundedIntegral _ = mempty
   & schemaType .~ SwaggerInteger
   & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
@@ -110,7 +110,7 @@ instance ToParamSchema Double where
 instance ToParamSchema Float where
   toParamSchema _ = mempty & schemaType .~ SwaggerNumber
 
-timeParamSchema :: String -> ParamSchema t i
+timeParamSchema :: String -> ParamSchema t
 timeParamSchema format = mempty
   & schemaType      .~ SwaggerString
   & schemaFormat    ?~ T.pack format
@@ -158,19 +158,19 @@ instance ToParamSchema a => ToParamSchema (Last a)    where toParamSchema _ = to
 instance ToParamSchema a => ToParamSchema (Dual a)    where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
 
 -- |
--- >>> encode (toParamSchema (Proxy :: Proxy ()) :: ParamSchema t Items)
+-- >>> encode $ toParamSchema (Proxy :: Proxy ())
 -- "{\"type\":\"string\",\"enum\":[\"_\"]}"
 instance ToParamSchema () where
   toParamSchema _ = mempty
     & schemaType .~ SwaggerString
     & schemaEnum ?~ ["_"]
 
 -- | A configurable generic @'ParamSchema'@ creator.
-genericToParamSchema :: forall proxy a t i. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t i
+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
 genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
 
 class GToParamSchema (f :: * -> *) where
-  gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i
+  gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
 
 instance GToParamSchema f => GToParamSchema (D1 d f) where
   gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -185,7 +185,7 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
   gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
 
 class GEnumParamSchema (f :: * -> *) where
-  genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i
+  genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
 
 instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
   genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)

src/Data/Swagger/Internal/Schema.hs

@@ -266,7 +266,7 @@ instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
     ref <- declareSchemaRef (Proxy :: Proxy a)
     return $ unnamed $ mempty
       & schemaType  .~ SwaggerArray
-      & schemaItems ?~ SchemaItemsObject ref
+      & schemaItems ?~ SwaggerItemsObject ref
 
 instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
 instance ToSchema Bool    where declareNamedSchema = plain . paramSchemaToSchema
@@ -449,7 +449,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
     | otherwise = do
         (_, schema) <- recordSchema
         case schema ^. schemaItems of
-          Just (SchemaItemsArray [_]) -> fieldSchema
+          Just (SwaggerItemsArray [_]) -> fieldSchema
           _ -> pure (unnamed schema)
     where
       recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
@@ -474,10 +474,10 @@ gdeclareSchemaRef opts proxy = do
       return $ Ref (Reference name)
     _ -> Inline <$> gdeclareSchema opts proxy
 
-appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
-appendItem x Nothing = Just (SchemaItemsArray [x])
-appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
-appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
+appendItem x Nothing = Just (SwaggerItemsArray [x])
+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
+appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
 
 withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
   SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema

src/Data/Swagger/Lens.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Data.Swagger.Lens where
@@ -43,8 +44,8 @@ makeLenses ''Items
 makeLenses ''Header
 -- ** 'Schema' lenses
 makeLenses ''Schema
--- ** 'SchemaItems' prisms
-makePrisms ''SchemaItems
+-- ** 'SwaggerItems' prisms
+makePrisms ''SwaggerItems
 -- ** 'ParamSchema' lenses
 makeLenses ''ParamSchema
 -- ** 'Xml' lenses
@@ -80,60 +81,60 @@ instance HasDescription Schema         (Maybe Text) where description = schemaDe
 instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription
 instance HasDescription ExternalDocs   (Maybe Text) where description = externalDocsDescription
 
-class HasParamSchema s t i | s -> t i where
-  parameterSchema :: Lens' s (ParamSchema t i)
+class HasParamSchema s t | s -> t where
+  parameterSchema :: Lens' s (ParamSchema t)
 
-instance HasParamSchema Schema Schema SchemaItems where parameterSchema = schemaParamSchema
-instance HasParamSchema ParamOtherSchema ParamOtherSchema Items where parameterSchema = paramOtherSchemaParamSchema
-instance HasParamSchema Items Items Items where parameterSchema = itemsParamSchema
-instance HasParamSchema Header Header Items where parameterSchema = headerParamSchema
-instance HasParamSchema (ParamSchema t i) t i where parameterSchema = id
+instance HasParamSchema Schema Schema where parameterSchema = schemaParamSchema
+instance HasParamSchema ParamOtherSchema ParamOtherSchema where parameterSchema = paramOtherSchemaParamSchema
+instance HasParamSchema Items Items where parameterSchema = itemsParamSchema
+instance HasParamSchema Header Header where parameterSchema = headerParamSchema
+instance HasParamSchema (ParamSchema t) t where parameterSchema = id
 
-schemaType :: HasParamSchema s t i => Lens' s (SwaggerType t)
+schemaType :: HasParamSchema s t => Lens' s (SwaggerType t)
 schemaType = parameterSchema.paramSchemaType
 
-schemaFormat :: HasParamSchema s t i => Lens' s (Maybe Format)
+schemaFormat :: HasParamSchema s t => Lens' s (Maybe Format)
 schemaFormat = parameterSchema.paramSchemaFormat
 
-schemaItems :: HasParamSchema s t i => Lens' s (Maybe i)
+schemaItems :: HasParamSchema s t => Lens' s (Maybe (SwaggerItems t))
 schemaItems = parameterSchema.paramSchemaItems
 
-schemaDefault :: HasParamSchema s t i => Lens' s (Maybe Value)
+schemaDefault :: HasParamSchema s t => Lens' s (Maybe Value)
 schemaDefault = parameterSchema.paramSchemaDefault
 
-schemaMaximum :: HasParamSchema s t i => Lens' s (Maybe Scientific)
+schemaMaximum :: HasParamSchema s t => Lens' s (Maybe Scientific)
 schemaMaximum = parameterSchema.paramSchemaMaximum
 
-schemaExclusiveMaximum :: HasParamSchema s t i => Lens' s (Maybe Bool)
+schemaExclusiveMaximum :: HasParamSchema s t => Lens' s (Maybe Bool)
 schemaExclusiveMaximum = parameterSchema.paramSchemaExclusiveMaximum
 
-schemaMinimum :: HasParamSchema s t i => Lens' s (Maybe Scientific)
+schemaMinimum :: HasParamSchema s t => Lens' s (Maybe Scientific)
 schemaMinimum = parameterSchema.paramSchemaMinimum
 
-schemaExclusiveMinimum :: HasParamSchema s t i => Lens' s (Maybe Bool)
+schemaExclusiveMinimum :: HasParamSchema s t => Lens' s (Maybe Bool)
 schemaExclusiveMinimum = parameterSchema.paramSchemaExclusiveMinimum
 
-schemaMaxLength :: HasParamSchema s t i => Lens' s (Maybe Integer)
+schemaMaxLength :: HasParamSchema s t => Lens' s (Maybe Integer)
 schemaMaxLength = parameterSchema.paramSchemaMaxLength
 
-schemaMinLength :: HasParamSchema s t i => Lens' s (Maybe Integer)
+schemaMinLength :: HasParamSchema s t => Lens' s (Maybe Integer)
 schemaMinLength = parameterSchema.paramSchemaMinLength
 
-schemaPattern :: HasParamSchema s t i => Lens' s (Maybe Text)
+schemaPattern :: HasParamSchema s t => Lens' s (Maybe Text)
 schemaPattern = parameterSchema.paramSchemaPattern
 
-schemaMaxItems :: HasParamSchema s t i => Lens' s (Maybe Integer)
+schemaMaxItems :: HasParamSchema s t => Lens' s (Maybe Integer)
 schemaMaxItems = parameterSchema.paramSchemaMaxItems
 
-schemaMinItems :: HasParamSchema s t i => Lens' s (Maybe Integer)
+schemaMinItems :: HasParamSchema s t => Lens' s (Maybe Integer)
 schemaMinItems = parameterSchema.paramSchemaMinItems
 
-schemaUniqueItems :: HasParamSchema s t i => Lens' s (Maybe Bool)
+schemaUniqueItems :: HasParamSchema s t => Lens' s (Maybe Bool)
 schemaUniqueItems = parameterSchema.paramSchemaUniqueItems
 
-schemaEnum :: HasParamSchema s t i => Lens' s (Maybe [Value])
+schemaEnum :: HasParamSchema s t => Lens' s (Maybe [Value])
 schemaEnum = parameterSchema.paramSchemaEnum
 
-schemaMultipleOf :: HasParamSchema s t i => Lens' s (Maybe Scientific)
+schemaMultipleOf :: HasParamSchema s t => Lens' s (Maybe Scientific)
 schemaMultipleOf = parameterSchema.paramSchemaMultipleOf