Put CollectionFormat in one place (closes #28).

This change places collection format in SwaggerItems.

src/Data/Swagger.hs

@@ -52,7 +52,6 @@ module Data.Swagger (
   ParamOtherSchema(..),
   ParamLocation(..),
   ParamName,
-  Items(..),
   Header(..),
   HeaderName,
   Example(..),

src/Data/Swagger/Internal.hs

@@ -319,15 +319,21 @@ data ParamOtherSchema = ParamOtherSchema
     -- Default value is @False@.
   , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
 
-    -- | Determines the format of the array if @'ParamArray'@ is used.
-    -- Default value is csv.
-  , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)
-
   , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
   } deriving (Eq, Show, Generic, Data, Typeable)
 
+-- | Items for @'SwaggerArray'@ schemas.
+--
+-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces.
+-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed.
+-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@.
+-- This is different from the original Swagger's <http://swagger.io/specification/#itemsObject Items Object>.
+--
+-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
+--
+-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
 data SwaggerItems t where
-  SwaggerItemsPrimitive :: Items               -> SwaggerItems t
+  SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
   SwaggerItemsObject    :: Referenced Schema   -> SwaggerItems Schema
   SwaggerItemsArray     :: [Referenced Schema] -> SwaggerItems Schema
 
@@ -341,9 +347,9 @@ swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimiti
 swaggerItemsDataType :: DataType
 swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
 
-instance {-# OVERLAPPABLE #-} Typeable t => Data (SwaggerItems t) where
+instance {-# OVERLAPPABLE #-} Data t => Data (SwaggerItems t) where
   gunfold k z c = case constrIndex c of
-    1 -> k (z SwaggerItemsPrimitive)
+    1 -> k (k (z SwaggerItemsPrimitive))
     _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
   toConstr _ = swaggerItemsPrimitiveConstr
   dataTypeOf _ = swaggerItemsDataType
@@ -508,7 +514,7 @@ deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data
 
 data Xml = Xml
   { -- | Replaces the name of the element/attribute used for the described schema property.
-    -- When defined within the @'Items'@ (items), it will affect the name of the individual XML elements within the list.
+    -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
     -- When defined alongside type being array (outside the items),
     -- it will affect the wrapping element and only if wrapped is true.
     -- If wrapped is false, it will be ignored.
@@ -534,14 +540,6 @@ data Xml = Xml
   , _xmlWrapped :: Maybe Bool
   } deriving (Eq, Show, Generic, Data, Typeable)
 
-data Items = Items
-  { -- | Determines the format of the array if type array is used.
-    -- Default value is @'ItemsCollectionCSV'@.
-    _itemsCollectionFormat :: Maybe (CollectionFormat Items)
-
-  , _itemsParamSchema :: ParamSchema Items
-  } deriving (Eq, Show, Generic, Data, Typeable)
-
 -- | A container for the expected responses of an operation.
 -- The container maps a HTTP response code to the expected response.
 -- It is not expected from the documentation to necessarily cover all possible HTTP response codes,
@@ -585,10 +583,6 @@ data Header = Header
   { -- | A short description of the header.
     _headerDescription :: Maybe Text
 
-    -- | Determines the format of the array if type array is used.
-    -- Default value is @'ItemsCollectionCSV'@.
-  , _headerCollectionFormat :: Maybe (CollectionFormat Items)
-
   , _headerParamSchema :: ParamSchema Header
   } deriving (Eq, Show, Generic, Data, Typeable)
 
@@ -942,13 +936,12 @@ instance ToJSON Schema where
 instance ToJSON Header where
   toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
 
-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
+  toJSON (SwaggerItemsPrimitive fmt schema) = object
+    [ "collectionFormat" .= fmt
+    , "items"            .= schema ]
+  toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
+  toJSON (SwaggerItemsArray  x) = object [ "items" .= x ]
 
 instance ToJSON Host where
   toJSON (Host host mport) = toJSON $
@@ -1017,7 +1010,7 @@ instance ToJSON (CollectionFormat t) where
   toJSON CollectionMulti = "multi"
 
 instance ToJSON (ParamSchema t) where
-  toJSON = genericToJSON (jsonPrefix "paramSchema")
+  toJSON = omitEmpties . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
 
 -- =======================================================================
 -- Manual FromJSON instances
@@ -1076,11 +1069,10 @@ instance FromJSON Schema where
 instance FromJSON Header where
   parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
 
-instance FromJSON Items where
-  parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items")
-
-instance {-# OVERLAPPABLE #-} FromJSON (SwaggerItems t) where
-  parseJSON js = SwaggerItemsPrimitive <$> parseJSON js
+instance {-# OVERLAPPABLE #-} (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
+  parseJSON (Object o) = SwaggerItemsPrimitive
+    <$> o .:? "collectionFormat"
+    <*> (o .: "items" >>= parseJSON)
 
 instance {-# OVERLAPPING #-} FromJSON (SwaggerItems Schema) where
   parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
@@ -1174,16 +1166,17 @@ instance FromJSON (SwaggerType ParamOtherSchema) where
 instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where
   parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
 
+instance {-# OVERLAPPABLE #-} FromJSON (CollectionFormat t) where
+  parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
+
 instance FromJSON (CollectionFormat Param) where
   parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
 
-instance FromJSON (CollectionFormat Items) where
-  parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
-
 -- 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)
 -- and primitive array items.
 instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
-  parseJSON = genericParseJSON (jsonPrefix "ParamSchema")
+  parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
+

src/Data/Swagger/Internal/ParamSchema.hs

@@ -174,7 +174,7 @@ instance ToParamSchema a => ToParamSchema (Dual a)    where toParamSchema _ = to
 instance ToParamSchema a => ToParamSchema [a] where
   toParamSchema _ = mempty
     & schemaType  .~ SwaggerArray
-    & schemaItems ?~ SwaggerItemsPrimitive (Items Nothing (toParamSchema (Proxy :: Proxy a)))
+    & schemaItems ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
 
 instance ToParamSchema a => ToParamSchema (Set a) where
   toParamSchema _ = toParamSchema (Proxy :: Proxy [a])

src/Data/Swagger/Internal/Utils.hs

@@ -14,6 +14,7 @@ import Data.Data
 import Data.Hashable (Hashable)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Map (Map)
 import Data.Monoid
 import Data.Text (Text)
 import GHC.Generics
@@ -66,14 +67,17 @@ genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a ->
 genericToJSONWithSub sub opts x =
   case genericToJSON opts x of
     Object o ->
-      let so = HashMap.lookupDefault (error "impossible") sub o
-      in Object (HashMap.delete sub o) <+> so
+      case HashMap.lookup sub o of
+        Just so -> Object (HashMap.delete sub o) <+> so
+        Nothing -> Object o -- no subjson, leaving object as is
     _ -> error "genericToJSONWithSub: subjson is not an object"
 
 genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
-genericParseJSONWithSub sub opts (Object o) = genericParseJSON opts js
+genericParseJSONWithSub sub opts js@(Object o)
+    = genericParseJSON opts js    -- try without subjson
+  <|> genericParseJSON opts js'   -- try with subjson
   where
-    js = Object (HashMap.insert sub (Object o) o)
+    js' = Object (HashMap.insert sub (Object o) o)
 genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
 
 (<+>) :: Value -> Value -> Value
@@ -119,6 +123,7 @@ class SwaggerMonoid m where
   swaggerMappend = mappend
 
 instance SwaggerMonoid [a]
+instance Ord k => SwaggerMonoid (Map k v)
 
 instance SwaggerMonoid Text where
   swaggerMempty = mempty

src/Data/Swagger/Lens.hs

@@ -38,8 +38,6 @@ makeLenses ''Param
 makePrisms ''ParamAnySchema
 -- ** 'ParamOtherSchema' lenses
 makeLenses ''ParamOtherSchema
--- ** 'Items' lenses
-makeLenses ''Items
 -- ** 'Header' lenses
 makeLenses ''Header
 -- ** 'Schema' lenses
@@ -86,7 +84,6 @@ class HasParamSchema s t | s -> t where
 
 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